code.delx.au - gnu-emacs/blob - lisp/wid-edit.el

   1 ;;; wid-edit.el --- Functions for creating and using widgets.
   2 ;;
   3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: extensions
   7 ;; Version: 1.9951
   8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; See `widget.el'.
  30
  31 ;;; Code:
  32
  33 (require 'widget)
  34 (eval-when-compile (require 'cl))
  35
  36 ;;; Compatibility.
  37
  38 (defun widget-event-point (event)
  39   "Character position of the end of event if that exists, or nil."
  40   (posn-point (event-end event)))
  41
  42 (defalias 'widget-read-event 'read-event)
  43
  44 (eval-and-compile
  45   (autoload 'pp-to-string "pp")
  46   (autoload 'Info-goto-node "info")
  47   (autoload 'finder-commentary "finder" nil t)
  48
  49   (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
  50     ;; We have the old custom-library, hack around it!
  51     (defmacro defgroup (&rest args) nil)
  52     (defmacro defcustom (var value doc &rest args)
  53       (` (defvar (, var) (, value) (, doc))))
  54     (defmacro defface (&rest args) nil)
  55     (define-widget-keywords :prefix :tag :load :link :options :type :group)
  56     (when (fboundp 'copy-face)
  57       (copy-face 'default 'widget-documentation-face)
  58       (copy-face 'bold 'widget-button-face)
  59       (copy-face 'italic 'widget-field-face)))
  60
  61   (unless (fboundp 'button-release-event-p)
  62     ;; XEmacs function missing from Emacs.
  63     (defun button-release-event-p (event)
  64       "Non-nil if EVENT is a mouse-button-release event object."
  65       (and (eventp event)
  66            (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3))
  67            (or (memq 'click (event-modifiers event))
  68                (memq  'drag (event-modifiers event)))))))
  69
  70 ;;; Customization.
  71
  72 (defgroup widgets nil
  73   "Customization support for the Widget Library."
  74   :link '(custom-manual "(widget)Top")
  75   :link '(url-link :tag "Development Page"
  76                    "http://www.dina.kvl.dk/~abraham/custom/")
  77   :link '(emacs-library-link :tag "Lisp File" "widget.el")
  78   :prefix "widget-"
  79   :group 'extensions
  80   :group 'hypermedia)
  81
  82 (defgroup widget-documentation nil
  83   "Options controling the display of documentation strings."
  84   :group 'widgets)
  85
  86 (defgroup widget-faces nil
  87   "Faces used by the widget library."
  88   :group 'widgets
  89   :group 'faces)
  90
  91 (defvar widget-documentation-face 'widget-documentation-face
  92   "Face used for documentation strings in widges.
  93 This exists as a variable so it can be set locally in certain buffers.")
  94
  95 (defface widget-documentation-face '((((class color)
  96                                        (background dark))
  97                                       (:foreground "lime green"))
  98                                      (((class color)
  99                                        (background light))
 100                                       (:foreground "dark green"))
 101                                      (t nil))
 102   "Face used for documentation text."
 103   :group 'widget-documentation
 104   :group 'widget-faces)
 105
 106 (defvar widget-button-face 'widget-button-face
 107   "Face used for buttons in widges.
 108 This exists as a variable so it can be set locally in certain buffers.")
 109
 110 (defface widget-button-face '((t (:bold t)))
 111   "Face used for widget buttons."
 112   :group 'widget-faces)
 113
 114 (defcustom widget-mouse-face 'highlight
 115   "Face used for widget buttons when the mouse is above them."
 116   :type 'face
 117   :group 'widget-faces)
 118
 119 (defface widget-field-face '((((class grayscale color)
 120                                (background light))
 121                               (:background "gray85"))
 122                              (((class grayscale color)
 123                                (background dark))
 124                               (:background "dim gray"))
 125                              (t
 126                               (:italic t)))
 127   "Face used for editable fields."
 128   :group 'widget-faces)
 129
 130 (defface widget-single-line-field-face '((((class grayscale color)
 131                                            (background light))
 132                                           (:background "gray85"))
 133                                          (((class grayscale color)
 134                                            (background dark))
 135                                           (:background "dim gray"))
 136                                          (t
 137                                           (:italic t)))
 138   "Face used for editable fields spanning only a single line."
 139   :group 'widget-faces)
 140
 141 ;;; This causes display-table to be loaded, and not usefully.
 142 ;;;(defvar widget-single-line-display-table
 143 ;;;  (let ((table (make-display-table)))
 144 ;;;    (aset table 9  "^I")
 145 ;;;    (aset table 10 "^J")
 146 ;;;    table)
 147 ;;;  "Display table used for single-line editable fields.")
 148
 149 ;;;(when (fboundp 'set-face-display-table)
 150 ;;;  (set-face-display-table 'widget-single-line-field-face
 151 ;;;                       widget-single-line-display-table))
 152
 153 ;;; Utility functions.
 154 ;;
 155 ;; These are not really widget specific.
 156
 157 (defun widget-princ-to-string (object)
 158   ;; Return string representation of OBJECT, any Lisp object.
 159   ;; No quoting characters are used; no delimiters are printed around
 160   ;; the contents of strings.
 161   (save-excursion
 162     (set-buffer (get-buffer-create " *widget-tmp*"))
 163     (erase-buffer)
 164     (let ((standard-output (current-buffer)))
 165       (princ object))
 166     (buffer-string)))
 167
 168 (defun widget-clear-undo ()
 169   "Clear all undo information."
 170   (buffer-disable-undo (current-buffer))
 171   (buffer-enable-undo))
 172
 173 (defcustom widget-menu-max-size 40
 174   "Largest number of items allowed in a popup-menu.
 175 Larger menus are read through the minibuffer."
 176   :group 'widgets
 177   :type 'integer)
 178
 179 (defcustom widget-menu-minibuffer-flag (string-match "XEmacs" emacs-version)
 180   "*Control how to ask for a choice from the keyboard.
 181 Non-nil means use the minibuffer;
 182 nil means read a single character."
 183   :group 'widgets
 184   :type 'boolean)
 185
 186 (defun widget-choose (title items &optional event)
 187   "Choose an item from a list.
 188
 189 First argument TITLE is the name of the list.
 190 Second argument ITEMS is an list whose members are either
 191  (NAME . VALUE), to indicate selectable items, or just strings to
 192  indicate unselectable items.
 193 Optional third argument EVENT is an input event.
 194
 195 The user is asked to choose between each NAME from the items alist,
 196 and the VALUE of the chosen element will be returned.  If EVENT is a
 197 mouse event, and the number of elements in items is less than
 198 `widget-menu-max-size', a popup menu will be used, otherwise the
 199 minibuffer."
 200   (cond ((and (< (length items) widget-menu-max-size)
 201               event (fboundp 'x-popup-menu) window-system)
 202          ;; We are in Emacs-19, pressed by the mouse
 203          (x-popup-menu event
 204                        (list title (cons "" items))))
 205         (widget-menu-minibuffer-flag
 206          ;; Read the choice of name from the minibuffer.
 207          (setq items (widget-remove-if 'stringp items))
 208          (let ((val (completing-read (concat title ": ") items nil t)))
 209            (if (stringp val)
 210                (let ((try (try-completion val items)))
 211                  (when (stringp try)
 212                    (setq val try))
 213                  (cdr (assoc val items)))
 214              nil)))
 215         (t
 216          ;; Construct a menu of the choices
 217          ;; and then use it for prompting for a single character.
 218          (let* ((overriding-terminal-local-map
 219                  (make-sparse-keymap))
 220                 map choice (next-digit ?0)
 221                 some-choice-enabled
 222                 value)
 223            ;; Define SPC as a prefix char to get to this menu.
 224            (define-key overriding-terminal-local-map " "
 225              (setq map (make-sparse-keymap title)))
 226            (save-excursion
 227              (set-buffer (get-buffer-create " widget-choose"))
 228              (erase-buffer)
 229              (insert "Available choices:\n\n")
 230              (while items
 231                (setq choice (car items) items (cdr items))
 232                (if (consp choice)
 233                    (let* ((name (car choice))
 234                          (function (cdr choice)))
 235                      (insert (format "%c = %s\n" next-digit name))
 236                      (define-key map (vector next-digit) function)
 237                      (setq some-choice-enabled t)))
 238                ;; Allocate digits to disabled alternatives
 239                ;; so that the digit of a given alternative never varies.
 240                (setq next-digit (1+ next-digit)))
 241              (insert "\nC-g = Quit"))
 242            (or some-choice-enabled
 243                (error "None of the choices is currently meaningful"))
 244            (define-key map [?\C-g] 'keyboard-quit)
 245            (define-key map [t] 'keyboard-quit)
 246            (define-key map [?\M-\C-v] 'scroll-other-window)
 247            (define-key map [?\M--] 'negative-argument)
 248            (setcdr map (nreverse (cdr map)))
 249            ;; Read a char with the menu, and return the result
 250            ;; that corresponds to it.
 251            (save-window-excursion
 252              (let ((buf (get-buffer " widget-choose")))
 253                (display-buffer buf)
 254                (let ((cursor-in-echo-area t)
 255                      keys
 256                      (char 0)
 257                      (arg 1))
 258                  (while (not (or (and (>= char ?0) (< char next-digit))
 259                                  (eq value 'keyboard-quit)))
 260                    ;; Unread a SPC to lead to our new menu.
 261                    (setq unread-command-events (cons ?\ unread-command-events))
 262                    (setq keys (read-key-sequence title))
 263                    (setq value (lookup-key overriding-terminal-local-map keys t)
 264                          char (string-to-char (substring keys 1)))
 265                    (cond ((eq value 'scroll-other-window)
 266                           (let ((minibuffer-scroll-window (get-buffer-window buf)))
 267                             (if (> 0 arg)
 268                                 (scroll-other-window-down (window-height minibuffer-scroll-window))
 269                               (scroll-other-window))
 270                             (setq arg 1)))
 271                          ((eq value 'negative-argument)
 272                           (setq arg -1))
 273                          (t
 274                           (setq arg 1)))))))
 275            (when (eq value 'keyboard-quit)
 276              (error "Canceled"))
 277            value))))
 278
 279 (defun widget-remove-if (predictate list)
 280   (let (result (tail list))
 281     (while tail
 282       (or (funcall predictate (car tail))
 283           (setq result (cons (car tail) result)))
 284       (setq tail (cdr tail)))
 285     (nreverse result)))
 286
 287 ;;; Widget text specifications.
 288 ;;
 289 ;; These functions are for specifying text properties.
 290
 291 (defcustom widget-field-add-space
 292   (or (< emacs-major-version 20)
 293       (and (eq emacs-major-version 20)
 294            (< emacs-minor-version 3))
 295       (not (string-match "XEmacs" emacs-version)))
 296   "Non-nil means add extra space at the end of editable text fields.
 297
 298 This is needed on all versions of Emacs, and on XEmacs before 20.3.
 299 If you don't add the space, it will become impossible to edit a zero
 300 size field."
 301   :type 'boolean
 302   :group 'widgets)
 303
 304 (defcustom widget-field-use-before-change
 305   (and (or (> emacs-minor-version 34)
 306            (> emacs-major-version 19))
 307        (not (string-match "XEmacs" emacs-version)))
 308   "Non-nil means use `before-change-functions' to track editable fields.
 309 This enables the use of undo, but doesn't work on Emacs 19.34 and earlier.
 310 Using before hooks also means that the :notify function can't know the
 311 new value."
 312   :type 'boolean
 313   :group 'widgets)
 314
 315 (defun widget-specify-field (widget from to)
 316   "Specify editable button for WIDGET between FROM and TO."
 317   ;; Terminating space is not part of the field, but necessary in
 318   ;; order for local-map to work.  Remove next sexp if local-map works
 319   ;; at the end of the overlay.
 320   (save-excursion
 321     (goto-char to)
 322     (cond ((null (widget-get widget :size))
 323            (forward-char 1))
 324           (widget-field-add-space
 325            (insert-and-inherit " ")))
 326     (setq to (point)))
 327   (let ((map (widget-get widget :keymap))
 328         (face (or (widget-get widget :value-face) 'widget-field-face))
 329         (help-echo (widget-get widget :help-echo))
 330         (overlay (make-overlay from to nil
 331                                nil (or (not widget-field-add-space)
 332                                        (widget-get widget :size)))))
 333     (unless (or (stringp help-echo) (null help-echo))
 334       (setq help-echo 'widget-mouse-help))
 335     (widget-put widget :field-overlay overlay)
 336     (overlay-put overlay 'detachable nil)
 337     (overlay-put overlay 'field widget)
 338     (overlay-put overlay 'local-map map)
 339     (overlay-put overlay 'keymap map)
 340     (overlay-put overlay 'face face)
 341     (overlay-put overlay 'balloon-help help-echo)
 342     (overlay-put overlay 'help-echo help-echo))
 343   (widget-specify-secret widget))
 344
 345 (defun widget-specify-secret (field)
 346   "Replace text in FIELD with value of `:secret', if non-nil."
 347   (let ((secret (widget-get field :secret))
 348         (size (widget-get field :size)))
 349     (when secret
 350       (let ((begin (widget-field-start field))
 351             (end (widget-field-end field)))
 352         (when size
 353           (while (and (> end begin)
 354                       (eq (char-after (1- end)) ?\ ))
 355             (setq end (1- end))))
 356         (while (< begin end)
 357           (let ((old (char-after begin)))
 358             (unless (eq old secret)
 359               (subst-char-in-region begin (1+ begin) old secret)
 360               (put-text-property begin (1+ begin) 'secret old))
 361             (setq begin (1+ begin))))))))
 362
 363 (defun widget-specify-button (widget from to)
 364   "Specify button for WIDGET between FROM and TO."
 365   (let ((face (widget-apply widget :button-face-get))
 366         (help-echo (widget-get widget :help-echo))
 367         (overlay (make-overlay from to nil t nil)))
 368     (widget-put widget :button-overlay overlay)
 369     (unless (or (null help-echo) (stringp help-echo))
 370       (setq help-echo 'widget-mouse-help))
 371     (overlay-put overlay 'button widget)
 372     (overlay-put overlay 'mouse-face widget-mouse-face)
 373     (overlay-put overlay 'balloon-help help-echo)
 374     (overlay-put overlay 'help-echo help-echo)
 375     (overlay-put overlay 'face face)))
 376
 377 (defun widget-mouse-help (extent)
 378   "Find mouse help string for button in extent."
 379   (let* ((widget (widget-at (extent-start-position extent)))
 380          (help-echo (and widget (widget-get widget :help-echo))))
 381     (cond ((stringp help-echo)
 382            help-echo)
 383           ((and (symbolp help-echo) (fboundp help-echo)
 384                 (stringp (setq help-echo (funcall help-echo widget))))
 385            help-echo)
 386           (t
 387            (format "(widget %S :help-echo %S)" widget help-echo)))))
 388
 389 (defun widget-specify-sample (widget from to)
 390   ;; Specify sample for WIDGET between FROM and TO.
 391   (let ((face (widget-apply widget :sample-face-get))
 392         (overlay (make-overlay from to nil t nil)))
 393     (overlay-put overlay 'face face)
 394     (widget-put widget :sample-overlay overlay)))
 395
 396 (defun widget-specify-doc (widget from to)
 397   ;; Specify documentation for WIDGET between FROM and TO.
 398   (let ((overlay (make-overlay from to nil t nil)))
 399     (overlay-put overlay 'widget-doc widget)
 400     (overlay-put overlay 'face widget-documentation-face)
 401     (widget-put widget :doc-overlay overlay)))
 402
 403 (defmacro widget-specify-insert (&rest form)
 404   ;; Execute FORM without inheriting any text properties.
 405   (`
 406    (save-restriction
 407      (let ((inhibit-read-only t)
 408            result
 409            before-change-functions
 410            after-change-functions)
 411        (insert "<>")
 412        (narrow-to-region (- (point) 2) (point))
 413        (goto-char (1+ (point-min)))
 414        (setq result (progn (,@ form)))
 415        (delete-region (point-min) (1+ (point-min)))
 416        (delete-region (1- (point-max)) (point-max))
 417        (goto-char (point-max))
 418        result))))
 419
 420 (defface widget-inactive-face '((((class grayscale color)
 421                                   (background dark))
 422                                  (:foreground "light gray"))
 423                                 (((class grayscale color)
 424                                   (background light))
 425                                  (:foreground "dim gray"))
 426                                 (t
 427                                  (:italic t)))
 428   "Face used for inactive widgets."
 429   :group 'widget-faces)
 430
 431 (defun widget-specify-inactive (widget from to)
 432   "Make WIDGET inactive for user modifications."
 433   (unless (widget-get widget :inactive)
 434     (let ((overlay (make-overlay from to nil t nil)))
 435       (overlay-put overlay 'face 'widget-inactive-face)
 436       ;; This is disabled, as it makes the mouse cursor change shape.
 437       ;; (overlay-put overlay 'mouse-face 'widget-inactive-face)
 438       (overlay-put overlay 'evaporate t)
 439       (overlay-put overlay 'priority 100)
 440       (overlay-put overlay (if (string-match "XEmacs" emacs-version)
 441                                'read-only
 442                              'modification-hooks) '(widget-overlay-inactive))
 443       (widget-put widget :inactive overlay))))
 444
 445 (defun widget-overlay-inactive (&rest junk)
 446   "Ignoring the arguments, signal an error."
 447   (unless inhibit-read-only
 448     (error "Attempt to modify inactive widget")))
 449
 450
 451 (defun widget-specify-active (widget)
 452   "Make WIDGET active for user modifications."
 453   (let ((inactive (widget-get widget :inactive)))
 454     (when inactive
 455       (delete-overlay inactive)
 456       (widget-put widget :inactive nil))))
 457
 458 ;;; Widget Properties.
 459
 460 (defsubst widget-type (widget)
 461   "Return the type of WIDGET, a symbol."
 462   (car widget))
 463
 464 (defun widget-get-indirect (widget property)
 465   "In WIDGET, get the value of PROPERTY.
 466 If the value is a symbol, return its binding.
 467 Otherwise, just return the value."
 468   (let ((value (widget-get widget property)))
 469     (if (symbolp value)
 470         (symbol-value value)
 471       value)))
 472
 473 (defun widget-member (widget property)
 474   "Non-nil iff there is a definition in WIDGET for PROPERTY."
 475   (cond ((widget-plist-member (cdr widget) property)
 476          t)
 477         ((car widget)
 478          (widget-member (get (car widget) 'widget-type) property))
 479         (t nil)))
 480
 481 (defun widget-value (widget)
 482   "Extract the current value of WIDGET."
 483   (widget-apply widget
 484                 :value-to-external (widget-apply widget :value-get)))
 485
 486 (defun widget-value-set (widget value)
 487   "Set the current value of WIDGET to VALUE."
 488   (widget-apply widget
 489                 :value-set (widget-apply widget
 490                                          :value-to-internal value)))
 491
 492 (defun widget-default-get (widget)
 493   "Extract the default value of WIDGET."
 494   (or (widget-get widget :value)
 495       (widget-apply widget :default-get)))
 496
 497 (defun widget-match-inline (widget vals)
 498   ;; In WIDGET, match the start of VALS.
 499   (cond ((widget-get widget :inline)
 500          (widget-apply widget :match-inline vals))
 501         ((and vals
 502               (widget-apply widget :match (car vals)))
 503          (cons (list (car vals)) (cdr vals)))
 504         (t nil)))
 505
 506 (defun widget-apply-action (widget &optional event)
 507   "Apply :action in WIDGET in response to EVENT."
 508   (if (widget-apply widget :active)
 509       (widget-apply widget :action event)
 510     (error "Attempt to perform action on inactive widget")))
 511
 512 ;;; Helper functions.
 513 ;;
 514 ;; These are widget specific.
 515
 516 ;;;###autoload
 517 (defun widget-prompt-value (widget prompt &optional value unbound)
 518   "Prompt for a value matching WIDGET, using PROMPT.
 519 The current value is assumed to be VALUE, unless UNBOUND is non-nil."
 520   (unless (listp widget)
 521     (setq widget (list widget)))
 522   (setq prompt (format "[%s] %s" (widget-type widget) prompt))
 523   (setq widget (widget-convert widget))
 524   (let ((answer (widget-apply widget :prompt-value prompt value unbound)))
 525     (unless (widget-apply widget :match answer)
 526       (error "Value does not match %S type." (car widget)))
 527     answer))
 528
 529 (defun widget-get-sibling (widget)
 530   "Get the item WIDGET is assumed to toggle.
 531 This is only meaningful for radio buttons or checkboxes in a list."
 532   (let* ((parent (widget-get widget :parent))
 533          (children (widget-get parent :children))
 534          child)
 535     (catch 'child
 536       (while children
 537         (setq child (car children)
 538               children (cdr children))
 539         (when (eq (widget-get child :button) widget)
 540           (throw 'child child)))
 541       nil)))
 542
 543 (defun widget-map-buttons (function &optional buffer maparg)
 544   "Map FUNCTION over the buttons in BUFFER.
 545 FUNCTION is called with the arguments WIDGET and MAPARG.
 546
 547 If FUNCTION returns non-nil, the walk is cancelled.
 548
 549 The arguments MAPARG, and BUFFER default to nil and (current-buffer),
 550 respectively."
 551   (let ((cur (point-min))
 552         (widget nil)
 553         (parent nil)
 554         (overlays (if buffer
 555                       (save-excursion (set-buffer buffer) (overlay-lists))
 556                     (overlay-lists))))
 557     (setq overlays (append (car overlays) (cdr overlays)))
 558     (while (setq cur (pop overlays))
 559       (setq widget (overlay-get cur 'button))
 560       (if (and widget (funcall function widget maparg))
 561           (setq overlays nil)))))
 562
 563 ;;; Glyphs.
 564
 565 (defcustom widget-glyph-directory (concat data-directory "custom/")
 566   "Where widget glyphs are located.
 567 If this variable is nil, widget will try to locate the directory
 568 automatically."
 569   :group 'widgets
 570   :type 'directory)
 571
 572 (defcustom widget-glyph-enable t
 573   "If non nil, use glyphs in images when available."
 574   :group 'widgets
 575   :type 'boolean)
 576
 577 (defcustom widget-image-conversion
 578   '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
 579     (xbm ".xbm"))
 580   "Conversion alist from image formats to file name suffixes."
 581   :group 'widgets
 582   :type '(repeat (cons :format "%v"
 583                        (symbol :tag "Image Format" unknown)
 584                        (repeat :tag "Suffixes"
 585                                (string :format "%v")))))
 586
 587 (defun widget-glyph-find (image tag)
 588   "Create a glyph corresponding to IMAGE with string TAG as fallback.
 589 IMAGE should either already be a glyph, or be a file name sans
 590 extension (xpm, xbm, gif, jpg, or png) located in
 591 `widget-glyph-directory'."
 592   (cond ((not (and image
 593                    (string-match "XEmacs" emacs-version)
 594                    widget-glyph-enable
 595                    (fboundp 'make-glyph)
 596                    (fboundp 'locate-file)
 597                    image))
 598          ;; We don't want or can't use glyphs.
 599          nil)
 600         ((and (fboundp 'glyphp)
 601               (glyphp image))
 602          ;; Already a glyph.  Use it.
 603          image)
 604         ((stringp image)
 605          ;; A string.  Look it up in relevant directories.
 606          (let* ((dirlist (list (or widget-glyph-directory
 607                                    (concat data-directory
 608                                            "custom/"))
 609                                data-directory))
 610                 (formats widget-image-conversion)
 611                 file)
 612            (while (and formats (not file))
 613              (when (valid-image-instantiator-format-p (car (car formats)))
 614                (setq file (locate-file image dirlist
 615                                        (mapconcat 'identity
 616                                                   (cdr (car formats))
 617                                                   ":"))))
 618              (unless file
 619                (setq formats (cdr formats))))
 620            (and file
 621                 ;; We create a glyph with the file as the default image
 622                 ;; instantiator, and the TAG fallback
 623                 (make-glyph (list (vector (car (car formats)) ':file file)
 624                                   (vector 'string ':data tag))))))
 625         ((valid-instantiator-p image 'image)
 626          ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
 627          (make-glyph (list image
 628                            (vector 'string ':data tag))))
 629         ((consp image)
 630          ;; This could be virtually anything.  Let `make-glyph' sort it out.
 631          (make-glyph image))
 632         (t
 633          ;; Oh well.
 634          nil)))
 635
 636 (defun widget-glyph-insert (widget tag image &optional down inactive)
 637   "In WIDGET, insert the text TAG or, if supported, IMAGE.
 638 IMAGE should either be a glyph, an image instantiator, or an image file
 639 name sans extension (xpm, xbm, gif, jpg, or png) located in
 640 `widget-glyph-directory'.
 641
 642 Optional arguments DOWN and INACTIVE is used instead of IMAGE when the
 643 glyph is pressed or inactive, respectively.
 644
 645 WARNING: If you call this with a glyph, and you want the user to be
 646 able to invoke the glyph, make sure it is unique.  If you use the
 647 same glyph for multiple widgets, invoking any of the glyphs will
 648 cause the last created widget to be invoked.
 649
 650 Instead of an instantiator, you can also use a list of instantiators,
 651 or whatever `make-glyph' will accept.  However, in that case you must
 652 provide the fallback TAG as a part of the instantiator yourself."
 653   (let ((glyph (widget-glyph-find image tag)))
 654     (if glyph
 655         (widget-glyph-insert-glyph widget
 656                                    glyph
 657                                    (widget-glyph-find down tag)
 658                                    (widget-glyph-find inactive tag))
 659       (insert tag))))
 660
 661 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
 662   "In WIDGET, insert GLYPH.
 663 If optional arguments DOWN and INACTIVE are given, they should be
 664 glyphs used when the widget is pushed and inactive, respectively."
 665   (when widget
 666     (set-glyph-property glyph 'widget widget)
 667     (when down
 668       (set-glyph-property down 'widget widget))
 669     (when inactive
 670       (set-glyph-property inactive 'widget widget)))
 671   (insert "*")
 672   (let ((ext (make-extent (point) (1- (point))))
 673         (help-echo (and widget (widget-get widget :help-echo))))
 674     (set-extent-property ext 'invisible t)
 675     (set-extent-property ext 'start-open t)
 676     (set-extent-property ext 'end-open t)
 677     (set-extent-end-glyph ext glyph)
 678     (when help-echo
 679       (set-extent-property ext 'balloon-help help-echo)
 680       (set-extent-property ext 'help-echo help-echo)))
 681   (when widget
 682     (widget-put widget :glyph-up glyph)
 683     (when down (widget-put widget :glyph-down down))
 684     (when inactive (widget-put widget :glyph-inactive inactive))))
 685
 686 ;;; Buttons.
 687
 688 (defgroup widget-button nil
 689   "The look of various kinds of buttons."
 690   :group 'widgets)
 691
 692 (defcustom widget-button-prefix ""
 693   "String used as prefix for buttons."
 694   :type 'string
 695   :group 'widget-button)
 696
 697 (defcustom widget-button-suffix ""
 698   "String used as suffix for buttons."
 699   :type 'string
 700   :group 'widget-button)
 701
 702 ;;; Creating Widgets.
 703
 704 ;;;###autoload
 705 (defun widget-create (type &rest args)
 706   "Create widget of TYPE.
 707 The optional ARGS are additional keyword arguments."
 708   (let ((widget (apply 'widget-convert type args)))
 709     (widget-apply widget :create)
 710     widget))
 711
 712 (defun widget-create-child-and-convert (parent type &rest args)
 713   "As part of the widget PARENT, create a child widget TYPE.
 714 The child is converted, using the keyword arguments ARGS."
 715   (let ((widget (apply 'widget-convert type args)))
 716     (widget-put widget :parent parent)
 717     (unless (widget-get widget :indent)
 718       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 719                                     (or (widget-get widget :extra-offset) 0)
 720                                     (widget-get parent :offset))))
 721     (widget-apply widget :create)
 722     widget))
 723
 724 (defun widget-create-child (parent type)
 725   "Create widget of TYPE."
 726   (let ((widget (copy-sequence type)))
 727     (widget-put widget :parent parent)
 728     (unless (widget-get widget :indent)
 729       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 730                                     (or (widget-get widget :extra-offset) 0)
 731                                     (widget-get parent :offset))))
 732     (widget-apply widget :create)
 733     widget))
 734
 735 (defun widget-create-child-value (parent type value)
 736   "Create widget of TYPE with value VALUE."
 737   (let ((widget (copy-sequence type)))
 738     (widget-put widget :value (widget-apply widget :value-to-internal value))
 739     (widget-put widget :parent parent)
 740     (unless (widget-get widget :indent)
 741       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 742                                     (or (widget-get widget :extra-offset) 0)
 743                                     (widget-get parent :offset))))
 744     (widget-apply widget :create)
 745     widget))
 746
 747 ;;;###autoload
 748 (defun widget-delete (widget)
 749   "Delete WIDGET."
 750   (widget-apply widget :delete))
 751
 752 (defun widget-convert (type &rest args)
 753   "Convert TYPE to a widget without inserting it in the buffer.
 754 The optional ARGS are additional keyword arguments."
 755   ;; Don't touch the type.
 756   (let* ((widget (if (symbolp type)
 757                      (list type)
 758                    (copy-sequence type)))
 759          (current widget)
 760          (keys args))
 761     ;; First set the :args keyword.
 762     (while (cdr current)                ;Look in the type.
 763       (let ((next (car (cdr current))))
 764         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 765             (setq current (cdr (cdr current)))
 766           (setcdr current (list :args (cdr current)))
 767           (setq current nil))))
 768     (while args                         ;Look in the args.
 769       (let ((next (nth 0 args)))
 770         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 771             (setq args (nthcdr 2 args))
 772           (widget-put widget :args args)
 773           (setq args nil))))
 774     ;; Then Convert the widget.
 775     (setq type widget)
 776     (while type
 777       (let ((convert-widget (plist-get (cdr type) :convert-widget)))
 778         (if convert-widget
 779             (setq widget (funcall convert-widget widget))))
 780       (setq type (get (car type) 'widget-type)))
 781     ;; Finally set the keyword args.
 782     (while keys
 783       (let ((next (nth 0 keys)))
 784         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 785             (progn
 786               (widget-put widget next (nth 1 keys))
 787               (setq keys (nthcdr 2 keys)))
 788           (setq keys nil))))
 789     ;; Convert the :value to internal format.
 790     (if (widget-member widget :value)
 791         (let ((value (widget-get widget :value)))
 792           (widget-put widget
 793                       :value (widget-apply widget :value-to-internal value))))
 794     ;; Return the newly create widget.
 795     widget))
 796
 797 (defun widget-insert (&rest args)
 798   "Call `insert' with ARGS and make the text read only."
 799   (let ((inhibit-read-only t)
 800         before-change-functions
 801         after-change-functions
 802         (from (point)))
 803     (apply 'insert args)))
 804
 805 (defun widget-convert-text (type from to
 806                                  &optional button-from button-to
 807                                  &rest args)
 808   "Return a widget of type TYPE with endpoint FROM TO.
 809 Optional ARGS are extra keyword arguments for TYPE.
 810 and TO will be used as the widgets end points. If optional arguments
 811 BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
 812 button end points.
 813 Optional ARGS are extra keyword arguments for TYPE."
 814   (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
 815         (from (copy-marker from))
 816         (to (copy-marker to)))
 817     (set-marker-insertion-type from t)
 818     (set-marker-insertion-type to nil)
 819     (widget-put widget :from from)
 820     (widget-put widget :to to)
 821     (when button-from
 822       (widget-specify-button widget button-from button-to))
 823     widget))
 824
 825 (defun widget-convert-button (type from to &rest args)
 826   "Return a widget of type TYPE with endpoint FROM TO.
 827 Optional ARGS are extra keyword arguments for TYPE.
 828 No text will be inserted to the buffer, instead the text between FROM
 829 and TO will be used as the widgets end points, as well as the widgets
 830 button end points."
 831   (apply 'widget-convert-text type from to from to args))
 832
 833 (defun widget-leave-text (widget)
 834   "Remove markers and overlays from WIDGET and its children."
 835   (let ((from (widget-get widget :from))
 836         (to (widget-get widget :to))
 837         (button (widget-get widget :button-overlay))
 838         (sample (widget-get widget :sample-overlay))
 839         (doc (widget-get widget :doc-overlay))
 840         (field (widget-get widget :field-overlay))
 841         (children (widget-get widget :children)))
 842     (set-marker from nil)
 843     (set-marker to nil)
 844     (when button
 845       (delete-overlay button))
 846     (when sample
 847       (delete-overlay sample))
 848     (when doc
 849       (delete-overlay doc))
 850     (when field
 851       (delete-overlay field))
 852     (mapcar 'widget-leave-text children)))
 853
 854 ;;; Keymap and Commands.
 855
 856 (defvar widget-keymap nil
 857   "Keymap containing useful binding for buffers containing widgets.
 858 Recommended as a parent keymap for modes using widgets.")
 859
 860 (unless widget-keymap
 861   (setq widget-keymap (make-sparse-keymap))
 862   (define-key widget-keymap "\t" 'widget-forward)
 863   (define-key widget-keymap [(shift tab)] 'widget-backward)
 864   (define-key widget-keymap [backtab] 'widget-backward)
 865   (if (string-match "XEmacs" emacs-version)
 866       (progn
 867         ;;Glyph support.
 868         (define-key widget-keymap [button1] 'widget-button1-click)
 869         (define-key widget-keymap [button2] 'widget-button-click))
 870     (define-key widget-keymap [down-mouse-2] 'widget-button-click))
 871   (define-key widget-keymap "\C-m" 'widget-button-press))
 872
 873 (defvar widget-global-map global-map
 874   "Keymap used for events the widget does not handle themselves.")
 875 (make-variable-buffer-local 'widget-global-map)
 876
 877 (defvar widget-field-keymap nil
 878   "Keymap used inside an editable field.")
 879
 880 (unless widget-field-keymap
 881   (setq widget-field-keymap (copy-keymap widget-keymap))
 882   (unless (string-match "XEmacs" (emacs-version))
 883     (define-key widget-field-keymap [menu-bar] 'nil))
 884   (define-key widget-field-keymap "\C-k" 'widget-kill-line)
 885   (define-key widget-field-keymap "\M-\t" 'widget-complete)
 886   (define-key widget-field-keymap "\C-m" 'widget-field-activate)
 887   (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
 888   (define-key widget-field-keymap "\C-e" 'widget-end-of-line)
 889   (set-keymap-parent widget-field-keymap global-map))
 890
 891 (defvar widget-text-keymap nil
 892   "Keymap used inside a text field.")
 893
 894 (unless widget-text-keymap
 895   (setq widget-text-keymap (copy-keymap widget-keymap))
 896   (unless (string-match "XEmacs" (emacs-version))
 897     (define-key widget-text-keymap [menu-bar] 'nil))
 898   (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
 899   (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
 900   (set-keymap-parent widget-text-keymap global-map))
 901
 902 (defun widget-field-activate (pos &optional event)
 903   "Invoke the ediable field at point."
 904   (interactive "@d")
 905   (let ((field (get-char-property pos 'field)))
 906     (if field
 907         (widget-apply-action field event)
 908       (call-interactively
 909        (lookup-key widget-global-map (this-command-keys))))))
 910
 911 (defface widget-button-pressed-face
 912   '((((class color))
 913      (:foreground "red"))
 914     (t
 915      (:bold t :underline t)))
 916   "Face used for pressed buttons."
 917   :group 'widget-faces)
 918
 919 (defun widget-button-click (event)
 920   "Invoke the button that the mouse is pointing at, and move there."
 921   (interactive "@e")
 922   (mouse-set-point event)
 923   (cond ((and (fboundp 'event-glyph)
 924               (event-glyph event))
 925          (widget-glyph-click event))
 926         ((widget-event-point event)
 927          (let* ((pos (widget-event-point event))
 928                 (button (get-char-property pos 'button)))
 929            (if button
 930                (let* ((overlay (widget-get button :button-overlay))
 931                       (face (overlay-get overlay 'face))
 932                       (mouse-face (overlay-get overlay 'mouse-face)))
 933                  (unwind-protect
 934                      (let ((track-mouse t))
 935                        (overlay-put overlay
 936                                     'face 'widget-button-pressed-face)
 937                        (overlay-put overlay
 938                                     'mouse-face 'widget-button-pressed-face)
 939                        (unless (widget-apply button :mouse-down-action event)
 940                          (while (not (button-release-event-p event))
 941                            (setq event (widget-read-event)
 942                                  pos (widget-event-point event))
 943                            (if (and pos
 944                                     (eq (get-char-property pos 'button)
 945                                         button))
 946                                (progn
 947                                  (overlay-put overlay
 948                                               'face
 949                                               'widget-button-pressed-face)
 950                                  (overlay-put overlay
 951                                               'mouse-face
 952                                               'widget-button-pressed-face))
 953                              (overlay-put overlay 'face face)
 954                              (overlay-put overlay 'mouse-face mouse-face))))
 955                        (when (and pos
 956                                   (eq (get-char-property pos 'button) button))
 957                          (widget-apply-action button event)))
 958                    (overlay-put overlay 'face face)
 959                    (overlay-put overlay 'mouse-face mouse-face)))
 960              (let ((up t)
 961                    command)
 962                ;; Find the global command to run, and check whether it
 963                ;; is bound to an up event.
 964                (cond ((setq command     ;down event
 965                             (lookup-key widget-global-map [ button2 ]))
 966                       (setq up nil))
 967                      ((setq command     ;down event
 968                             (lookup-key widget-global-map [ down-mouse-2 ]))
 969                       (setq up nil))
 970                      ((setq command     ;up event
 971                             (lookup-key widget-global-map [ button2up ])))
 972                      ((setq command     ;up event
 973                             (lookup-key widget-global-map [ mouse-2]))))
 974                (when up
 975                  ;; Don't execute up events twice.
 976                  (while (not (button-release-event-p event))
 977                    (setq event (widget-read-event))))
 978                (when command
 979                  (call-interactively command))))))
 980         (t
 981          (message "You clicked somewhere weird."))))
 982
 983 (defun widget-button1-click (event)
 984   "Invoke glyph below mouse pointer."
 985   (interactive "@e")
 986   (if (and (fboundp 'event-glyph)
 987            (event-glyph event))
 988       (widget-glyph-click event)
 989     (call-interactively (lookup-key widget-global-map (this-command-keys)))))
 990
 991 (defun widget-glyph-click (event)
 992   "Handle click on a glyph."
 993   (let* ((glyph (event-glyph event))
 994          (widget (glyph-property glyph 'widget))
 995          (extent (event-glyph-extent event))
 996          (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph))
 997          (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph))
 998          (last event))
 999     ;; Wait for the release.
1000     (while (not (button-release-event-p last))
1001       (if (eq extent (event-glyph-extent last))
1002           (set-extent-property extent 'end-glyph down-glyph)
1003         (set-extent-property extent 'end-glyph up-glyph))
1004       (setq last (read-event event)))
1005     ;; Release glyph.
1006     (when down-glyph
1007       (set-extent-property extent 'end-glyph up-glyph))
1008     ;; Apply widget action.
1009     (when (eq extent (event-glyph-extent last))
1010       (let ((widget (glyph-property (event-glyph event) 'widget)))
1011         (cond ((null widget)
1012                (message "You clicked on a glyph."))
1013               ((not (widget-apply widget :active))
1014                (message "This glyph is inactive."))
1015               (t
1016                (widget-apply-action widget event)))))))
1017
1018 (defun widget-button-press (pos &optional event)
1019   "Invoke button at POS."
1020   (interactive "@d")
1021   (let ((button (get-char-property pos 'button)))
1022     (if button
1023         (widget-apply-action button event)
1024       (let ((command (lookup-key widget-global-map (this-command-keys))))
1025         (when (commandp command)
1026           (call-interactively command))))))
1027
1028 (defun widget-tabable-at (&optional pos)
1029   "Return the tabable widget at POS, or nil.
1030 POS defaults to the value of (point)."
1031   (unless pos
1032     (setq pos (point)))
1033   (let ((widget (or (get-char-property (point) 'button)
1034                     (get-char-property (point) 'field))))
1035     (if widget
1036         (let ((order (widget-get widget :tab-order)))
1037           (if order
1038               (if (>= order 0)
1039                   widget
1040                 nil)
1041             widget))
1042       nil)))
1043
1044 (defcustom widget-use-overlay-change (string-match "XEmacs" emacs-version)
1045   "If non-nil, use overlay change functions to tab around in the buffer.
1046 This is much faster, but doesn't work reliably on Emacs 19.34."
1047   :type 'boolean
1048   :group 'widgets)
1049
1050 (defun widget-move (arg)
1051   "Move point to the ARG next field or button.
1052 ARG may be negative to move backward."
1053   (or (bobp) (> arg 0) (backward-char))
1054   (let ((pos (point))
1055         (number arg)
1056         (old (widget-tabable-at))
1057         new)
1058     ;; Forward.
1059     (while (> arg 0)
1060       (cond ((eobp)
1061              (goto-char (point-min)))
1062             (widget-use-overlay-change
1063              (goto-char (next-overlay-change (point))))
1064             (t
1065              (forward-char 1)))
1066       (and (eq pos (point))
1067            (eq arg number)
1068            (error "No buttons or fields found"))
1069       (let ((new (widget-tabable-at)))
1070         (when new
1071           (unless (eq new old)
1072             (setq arg (1- arg))
1073             (setq old new)))))
1074     ;; Backward.
1075     (while (< arg 0)
1076       (cond ((bobp)
1077              (goto-char (point-max)))
1078             (widget-use-overlay-change
1079              (goto-char (previous-overlay-change (point))))
1080             (t
1081              (backward-char 1)))
1082       (and (eq pos (point))
1083            (eq arg number)
1084            (error "No buttons or fields found"))
1085       (let ((new (widget-tabable-at)))
1086         (when new
1087           (unless (eq new old)
1088             (setq arg (1+ arg))))))
1089     (let ((new (widget-tabable-at)))
1090       (while (eq (widget-tabable-at) new)
1091         (backward-char)))
1092     (forward-char))
1093   (widget-echo-help (point))
1094   (run-hooks 'widget-move-hook))
1095
1096 (defun widget-forward (arg)
1097   "Move point to the next field or button.
1098 With optional ARG, move across that many fields."
1099   (interactive "p")
1100   (run-hooks 'widget-forward-hook)
1101   (widget-move arg))
1102
1103 (defun widget-backward (arg)
1104   "Move point to the previous field or button.
1105 With optional ARG, move across that many fields."
1106   (interactive "p")
1107   (run-hooks 'widget-backward-hook)
1108   (widget-move (- arg)))
1109
1110 (defun widget-beginning-of-line ()
1111   "Go to beginning of field or beginning of line, whichever is first."
1112   (interactive)
1113   (let* ((field (widget-field-find (point)))
1114          (start (and field (widget-field-start field)))
1115          (bol (save-excursion
1116                 (beginning-of-line)
1117                 (point))))
1118     (goto-char (if start
1119                    (max start bol)
1120                  bol))))
1121
1122 (defun widget-end-of-line ()
1123   "Go to end of field or end of line, whichever is first."
1124   (interactive)
1125   (let* ((field (widget-field-find (point)))
1126          (end (and field (widget-field-end field)))
1127          (eol (save-excursion
1128                 (end-of-line)
1129                 (point))))
1130     (goto-char (if end
1131                    (min end eol)
1132                  eol))))
1133
1134 (defun widget-kill-line ()
1135   "Kill to end of field or end of line, whichever is first."
1136   (interactive)
1137   (let* ((field (widget-field-find (point)))
1138          (newline (save-excursion (forward-line 1) (point)))
1139          (end (and field (widget-field-end field))))
1140     (if (and field (> newline end))
1141         (kill-region (point) end)
1142       (call-interactively 'kill-line))))
1143
1144 (defcustom widget-complete-field (lookup-key global-map "\M-\t")
1145   "Default function to call for completion inside fields."
1146   :options '(ispell-complete-word complete-tag lisp-complete-symbol)
1147   :type 'function
1148   :group 'widgets)
1149
1150 (defun widget-complete ()
1151   "Complete content of editable field from point.
1152 When not inside a field, move to the previous button or field."
1153   (interactive)
1154   (let ((field (widget-field-find (point))))
1155     (if field
1156         (widget-apply field :complete)
1157       (error "Not in an editable field"))))
1158
1159 ;;; Setting up the buffer.
1160
1161 (defvar widget-field-new nil)
1162 ;; List of all newly created editable fields in the buffer.
1163 (make-variable-buffer-local 'widget-field-new)
1164
1165 (defvar widget-field-list nil)
1166 ;; List of all editable fields in the buffer.
1167 (make-variable-buffer-local 'widget-field-list)
1168
1169 (defun widget-setup ()
1170   "Setup current buffer so editing string widgets works."
1171   (let ((inhibit-read-only t)
1172         (after-change-functions nil)
1173         before-change-functions
1174         field)
1175     (while widget-field-new
1176       (setq field (car widget-field-new)
1177             widget-field-new (cdr widget-field-new)
1178             widget-field-list (cons field widget-field-list))
1179       (let ((from (car (widget-get field :field-overlay)))
1180             (to (cdr (widget-get field :field-overlay))))
1181         (widget-specify-field field
1182                               (marker-position from) (marker-position to))
1183         (set-marker from nil)
1184         (set-marker to nil))))
1185   (widget-clear-undo)
1186   (widget-add-change))
1187
1188 (defvar widget-field-last nil)
1189 ;; Last field containing point.
1190 (make-variable-buffer-local 'widget-field-last)
1191
1192 (defvar widget-field-was nil)
1193 ;; The widget data before the change.
1194 (make-variable-buffer-local 'widget-field-was)
1195
1196 (defun widget-field-buffer (widget)
1197   "Return the start of WIDGET's editing field."
1198   (let ((overlay (widget-get widget :field-overlay)))
1199     (and overlay (overlay-buffer overlay))))
1200
1201 (defun widget-field-start (widget)
1202   "Return the start of WIDGET's editing field."
1203   (let ((overlay (widget-get widget :field-overlay)))
1204     (and overlay (overlay-start overlay))))
1205
1206 (defun widget-field-end (widget)
1207   "Return the end of WIDGET's editing field."
1208   (let ((overlay (widget-get widget :field-overlay)))
1209     ;; Don't subtract one if local-map works at the end of the overlay.
1210     (and overlay (if (or widget-field-add-space
1211                          (null (widget-get widget :size)))
1212                      (1- (overlay-end overlay))
1213                    (overlay-end overlay)))))
1214
1215 (defun widget-field-find (pos)
1216   "Return the field at POS.
1217 Unlike (get-char-property POS 'field) this, works with empty fields too."
1218   (let ((fields widget-field-list)
1219         field found)
1220     (while fields
1221       (setq field (car fields)
1222             fields (cdr fields))
1223       (let ((start (widget-field-start field))
1224             (end (widget-field-end field)))
1225         (when (and (<= start pos) (<= pos end))
1226           (when found
1227             (debug "Overlapping fields"))
1228           (setq found field))))
1229     found))
1230
1231 (defun widget-before-change (from to)
1232   ;; This is how, for example, a variable changes its state to `modified'.
1233   ;; when it is being edited.
1234   (unless inhibit-read-only
1235     (let ((from-field (widget-field-find from))
1236           (to-field (widget-field-find to)))
1237       (cond ((not (eq from-field to-field))
1238              (add-hook 'post-command-hook 'widget-add-change nil t)
1239              (error "Change should be restricted to a single field"))
1240             ((null from-field)
1241              (add-hook 'post-command-hook 'widget-add-change nil t)
1242              (error "Attempt to change text outside editable field"))
1243             (widget-field-use-before-change
1244              (condition-case nil
1245                  (widget-apply from-field :notify from-field)
1246                (error (debug "Before Change"))))))))
1247
1248 (defun widget-add-change ()
1249   (make-local-hook 'post-command-hook)
1250   (remove-hook 'post-command-hook 'widget-add-change t)
1251   (make-local-hook 'before-change-functions)
1252   (add-hook 'before-change-functions 'widget-before-change nil t)
1253   (make-local-hook 'after-change-functions)
1254   (add-hook 'after-change-functions 'widget-after-change nil t))
1255
1256 (defun widget-after-change (from to old)
1257   ;; Adjust field size and text properties.
1258   (condition-case nil
1259       (let ((field (widget-field-find from))
1260             (other (widget-field-find to)))
1261         (when field
1262           (unless (eq field other)
1263             (debug "Change in different fields"))
1264           (let ((size (widget-get field :size)))
1265             (when size
1266               (let ((begin (widget-field-start field))
1267                     (end (widget-field-end field)))
1268                 (cond ((< (- end begin) size)
1269                        ;; Field too small.
1270                        (save-excursion
1271                          (goto-char end)
1272                          (insert-char ?\  (- (+ begin size) end))))
1273                       ((> (- end begin) size)
1274                        ;; Field too large and
1275                        (if (or (< (point) (+ begin size))
1276                                (> (point) end))
1277                            ;; Point is outside extra space.
1278                            (setq begin (+ begin size))
1279                          ;; Point is within the extra space.
1280                          (setq begin (point)))
1281                        (save-excursion
1282                          (goto-char end)
1283                          (while (and (eq (preceding-char) ?\ )
1284                                      (> (point) begin))
1285                            (delete-backward-char 1)))))))
1286             (widget-specify-secret field))
1287           (widget-apply field :notify field)))
1288     (error (debug "After Change"))))
1289
1290 ;;; Widget Functions
1291 ;;
1292 ;; These functions are used in the definition of multiple widgets.
1293
1294 (defun widget-parent-action (widget &optional event)
1295   "Tell :parent of WIDGET to handle the :action.
1296 Optional EVENT is the event that triggered the action."
1297   (widget-apply (widget-get widget :parent) :action event))
1298
1299 (defun widget-children-value-delete (widget)
1300   "Delete all :children and :buttons in WIDGET."
1301   (mapcar 'widget-delete (widget-get widget :children))
1302   (widget-put widget :children nil)
1303   (mapcar 'widget-delete (widget-get widget :buttons))
1304   (widget-put widget :buttons nil))
1305
1306 (defun widget-children-validate (widget)
1307   "All the :children must be valid."
1308   (let ((children (widget-get widget :children))
1309         child found)
1310     (while (and children (not found))
1311       (setq child (car children)
1312             children (cdr children)
1313             found (widget-apply child :validate)))
1314     found))
1315
1316 (defun widget-types-convert-widget (widget)
1317   "Convert :args as widget types in WIDGET."
1318   (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
1319   widget)
1320
1321 (defun widget-value-convert-widget (widget)
1322   "Initialize :value from :args in WIDGET."
1323   (let ((args (widget-get widget :args)))
1324     (when args
1325       (widget-put widget :value (car args))
1326       ;; Don't convert :value here, as this is done in `widget-convert'.
1327       ;; (widget-put widget :value (widget-apply widget
1328       ;;                                      :value-to-internal (car args)))
1329       (widget-put widget :args nil)))
1330   widget)
1331
1332 (defun widget-value-value-get (widget)
1333   "Return the :value property of WIDGET."
1334   (widget-get widget :value))
1335
1336 ;;; The `default' Widget.
1337
1338 (define-widget 'default nil
1339   "Basic widget other widgets are derived from."
1340   :value-to-internal (lambda (widget value) value)
1341   :value-to-external (lambda (widget value) value)
1342   :button-prefix 'widget-button-prefix
1343   :button-suffix 'widget-button-suffix
1344   :complete 'widget-default-complete
1345   :create 'widget-default-create
1346   :indent nil
1347   :offset 0
1348   :format-handler 'widget-default-format-handler
1349   :button-face-get 'widget-default-button-face-get
1350   :sample-face-get 'widget-default-sample-face-get
1351   :delete 'widget-default-delete
1352   :value-set 'widget-default-value-set
1353   :value-inline 'widget-default-value-inline
1354   :default-get 'widget-default-default-get
1355   :menu-tag-get 'widget-default-menu-tag-get
1356   :validate (lambda (widget) nil)
1357   :active 'widget-default-active
1358   :activate 'widget-specify-active
1359   :deactivate 'widget-default-deactivate
1360   :mouse-down-action (lambda (widget event) nil)
1361   :action 'widget-default-action
1362   :notify 'widget-default-notify
1363   :prompt-value 'widget-default-prompt-value)
1364
1365 (defun widget-default-complete (widget)
1366   "Call the value of the :complete-function property of WIDGET.
1367 If that does not exists, call the value of `widget-complete-field'."
1368   (let ((fun (widget-get widget :complete-function)))
1369     (call-interactively (or fun widget-complete-field))))
1370
1371 (defun widget-default-create (widget)
1372   "Create WIDGET at point in the current buffer."
1373   (widget-specify-insert
1374    (let ((from (point))
1375          button-begin button-end
1376          sample-begin sample-end
1377          doc-begin doc-end
1378          value-pos)
1379      (insert (widget-get widget :format))
1380      (goto-char from)
1381      ;; Parse escapes in format.
1382      (while (re-search-forward "%\\(.\\)" nil t)
1383        (let ((escape (aref (match-string 1) 0)))
1384          (replace-match "" t t)
1385          (cond ((eq escape ?%)
1386                 (insert "%"))
1387                ((eq escape ?\[)
1388                 (setq button-begin (point))
1389                 (insert (widget-get-indirect widget :button-prefix)))
1390                ((eq escape ?\])
1391                 (insert (widget-get-indirect widget :button-suffix))
1392                 (setq button-end (point)))
1393                ((eq escape ?\{)
1394                 (setq sample-begin (point)))
1395                ((eq escape ?\})
1396                 (setq sample-end (point)))
1397                ((eq escape ?n)
1398                 (when (widget-get widget :indent)
1399                   (insert "\n")
1400                   (insert-char ?  (widget-get widget :indent))))
1401                ((eq escape ?t)
1402                 (let ((glyph (widget-get widget :tag-glyph))
1403                       (tag (widget-get widget :tag)))
1404                   (cond (glyph
1405                          (widget-glyph-insert widget (or tag "image") glyph))
1406                         (tag
1407                          (insert tag))
1408                         (t
1409                          (let ((standard-output (current-buffer)))
1410                            (princ (widget-get widget :value)))))))
1411                ((eq escape ?d)
1412                 (let ((doc (widget-get widget :doc)))
1413                   (when doc
1414                     (setq doc-begin (point))
1415                     (insert doc)
1416                     (while (eq (preceding-char) ?\n)
1417                       (delete-backward-char 1))
1418                     (insert "\n")
1419                     (setq doc-end (point)))))
1420                ((eq escape ?v)
1421                 (if (and button-begin (not button-end))
1422                     (widget-apply widget :value-create)
1423                   (setq value-pos (point))))
1424                (t
1425                 (widget-apply widget :format-handler escape)))))
1426      ;; Specify button, sample, and doc, and insert value.
1427      (and button-begin button-end
1428           (widget-specify-button widget button-begin button-end))
1429      (and sample-begin sample-end
1430           (widget-specify-sample widget sample-begin sample-end))
1431      (and doc-begin doc-end
1432           (widget-specify-doc widget doc-begin doc-end))
1433      (when value-pos
1434        (goto-char value-pos)
1435        (widget-apply widget :value-create)))
1436    (let ((from (copy-marker (point-min)))
1437          (to (copy-marker (point-max))))
1438      (set-marker-insertion-type from t)
1439      (set-marker-insertion-type to nil)
1440      (widget-put widget :from from)
1441      (widget-put widget :to to)))
1442   (widget-clear-undo))
1443
1444 (defun widget-default-format-handler (widget escape)
1445   ;; We recognize the %h escape by default.
1446   (let* ((buttons (widget-get widget :buttons)))
1447     (cond ((eq escape ?h)
1448            (let* ((doc-property (widget-get widget :documentation-property))
1449                   (doc-try (cond ((widget-get widget :doc))
1450                                  ((symbolp doc-property)
1451                                   (documentation-property
1452                                    (widget-get widget :value)
1453                                    doc-property))
1454                                  (t
1455                                   (funcall doc-property
1456                                            (widget-get widget :value)))))
1457                   (doc-text (and (stringp doc-try)
1458                                  (> (length doc-try) 1)
1459                                  doc-try))
1460                   (doc-indent (widget-get widget :documentation-indent)))
1461              (when doc-text
1462                (and (eq (preceding-char) ?\n)
1463                     (widget-get widget :indent)
1464                     (insert-char ?  (widget-get widget :indent)))
1465                ;; The `*' in the beginning is redundant.
1466                (when (eq (aref doc-text  0) ?*)
1467                  (setq doc-text (substring doc-text 1)))
1468                ;; Get rid of trailing newlines.
1469                (when (string-match "\n+\\'" doc-text)
1470                  (setq doc-text (substring doc-text 0 (match-beginning 0))))
1471                (push (widget-create-child-and-convert
1472                       widget 'documentation-string
1473                       :indent (cond ((numberp doc-indent )
1474                                      doc-indent)
1475                                     ((null doc-indent)
1476                                      nil)
1477                                     (t 0))
1478                       doc-text)
1479                      buttons))))
1480           (t
1481            (error "Unknown escape `%c'" escape)))
1482     (widget-put widget :buttons buttons)))
1483
1484 (defun widget-default-button-face-get (widget)
1485   ;; Use :button-face or widget-button-face
1486   (or (widget-get widget :button-face)
1487       (let ((parent (widget-get widget :parent)))
1488         (if parent
1489             (widget-apply parent :button-face-get)
1490           widget-button-face))))
1491
1492 (defun widget-default-sample-face-get (widget)
1493   ;; Use :sample-face.
1494   (widget-get widget :sample-face))
1495
1496 (defun widget-default-delete (widget)
1497   ;; Remove widget from the buffer.
1498   (let ((from (widget-get widget :from))
1499         (to (widget-get widget :to))
1500         (inactive-overlay (widget-get widget :inactive))
1501         (button-overlay (widget-get widget :button-overlay))
1502         (sample-overlay (widget-get widget :sample-overlay))
1503         (doc-overlay (widget-get widget :doc-overlay))
1504         before-change-functions
1505         after-change-functions
1506         (inhibit-read-only t))
1507     (widget-apply widget :value-delete)
1508     (when inactive-overlay
1509       (delete-overlay inactive-overlay))
1510     (when button-overlay
1511       (delete-overlay button-overlay))
1512     (when sample-overlay
1513       (delete-overlay sample-overlay))
1514     (when doc-overlay
1515       (delete-overlay doc-overlay))
1516     (when (< from to)
1517       ;; Kludge: this doesn't need to be true for empty formats.
1518       (delete-region from to))
1519     (set-marker from nil)
1520     (set-marker to nil))
1521   (widget-clear-undo))
1522
1523 (defun widget-default-value-set (widget value)
1524   ;; Recreate widget with new value.
1525   (let* ((old-pos (point))
1526          (from (copy-marker (widget-get widget :from)))
1527          (to (copy-marker (widget-get widget :to)))
1528          (offset (if (and (<= from old-pos) (<= old-pos to))
1529                      (if (>= old-pos (1- to))
1530                          (- old-pos to 1)
1531                        (- old-pos from)))))
1532     ;;??? Bug: this ought to insert the new value before deleting the old one,
1533     ;; so that markers on either side of the value automatically
1534     ;; stay on the same side.  -- rms.
1535     (save-excursion
1536       (goto-char (widget-get widget :from))
1537       (widget-apply widget :delete)
1538       (widget-put widget :value value)
1539       (widget-apply widget :create))
1540     (if offset
1541         (if (< offset 0)
1542             (goto-char (+ (widget-get widget :to) offset 1))
1543           (goto-char (min (+ from offset) (1- (widget-get widget :to))))))))
1544
1545 (defun widget-default-value-inline (widget)
1546   ;; Wrap value in a list unless it is inline.
1547   (if (widget-get widget :inline)
1548       (widget-value widget)
1549     (list (widget-value widget))))
1550
1551 (defun widget-default-default-get (widget)
1552   ;; Get `:value'.
1553   (widget-get widget :value))
1554
1555 (defun widget-default-menu-tag-get (widget)
1556   ;; Use tag or value for menus.
1557   (or (widget-get widget :menu-tag)
1558       (widget-get widget :tag)
1559       (widget-princ-to-string (widget-get widget :value))))
1560
1561 (defun widget-default-active (widget)
1562   "Return t iff this widget active (user modifiable)."
1563   (and (not (widget-get widget :inactive))
1564        (let ((parent (widget-get widget :parent)))
1565          (or (null parent)
1566              (widget-apply parent :active)))))
1567
1568 (defun widget-default-deactivate (widget)
1569   "Make WIDGET inactive for user modifications."
1570   (widget-specify-inactive widget
1571                            (widget-get widget :from)
1572                            (widget-get widget :to)))
1573
1574 (defun widget-default-action (widget &optional event)
1575   ;; Notify the parent when a widget change
1576   (let ((parent (widget-get widget :parent)))
1577     (when parent
1578       (widget-apply parent :notify widget event))))
1579
1580 (defun widget-default-notify (widget child &optional event)
1581   ;; Pass notification to parent.
1582   (widget-default-action widget event))
1583
1584 (defun widget-default-prompt-value (widget prompt value unbound)
1585   ;; Read an arbitrary value.  Stolen from `set-variable'.
1586 ;;  (let ((initial (if unbound
1587 ;;                   nil
1588 ;;                 ;; It would be nice if we could do a `(cons val 1)' here.
1589 ;;                 (prin1-to-string (custom-quote value))))))
1590   (eval-minibuffer prompt ))
1591
1592 ;;; The `item' Widget.
1593
1594 (define-widget 'item 'default
1595   "Constant items for inclusion in other widgets."
1596   :convert-widget 'widget-value-convert-widget
1597   :value-create 'widget-item-value-create
1598   :value-delete 'ignore
1599   :value-get 'widget-value-value-get
1600   :match 'widget-item-match
1601   :match-inline 'widget-item-match-inline
1602   :action 'widget-item-action
1603   :format "%t\n")
1604
1605 (defun widget-item-value-create (widget)
1606   ;; Insert the printed representation of the value.
1607   (let ((standard-output (current-buffer)))
1608     (princ (widget-get widget :value))))
1609
1610 (defun widget-item-match (widget value)
1611   ;; Match if the value is the same.
1612   (equal (widget-get widget :value) value))
1613
1614 (defun widget-item-match-inline (widget values)
1615   ;; Match if the value is the same.
1616   (let ((value (widget-get widget :value)))
1617     (and (listp value)
1618          (<= (length value) (length values))
1619          (let ((head (widget-sublist values 0 (length value))))
1620            (and (equal head value)
1621                 (cons head (widget-sublist values (length value))))))))
1622
1623 (defun widget-sublist (list start &optional end)
1624   "Return the sublist of LIST from START to END.
1625 If END is omitted, it defaults to the length of LIST."
1626   (if (> start 0) (setq list (nthcdr start list)))
1627   (if end
1628       (if (<= end start)
1629           nil
1630         (setq list (copy-sequence list))
1631         (setcdr (nthcdr (- end start 1) list) nil)
1632         list)
1633     (copy-sequence list)))
1634
1635 (defun widget-item-action (widget &optional event)
1636   ;; Just notify itself.
1637   (widget-apply widget :notify widget event))
1638
1639 ;;; The `push-button' Widget.
1640
1641 (defcustom widget-push-button-gui t
1642   "If non nil, use GUI push buttons when available."
1643   :group 'widgets
1644   :type 'boolean)
1645
1646 ;; Cache already created GUI objects.
1647 (defvar widget-push-button-cache nil)
1648
1649 (defcustom widget-push-button-prefix "["
1650   "String used as prefix for buttons."
1651   :type 'string
1652   :group 'widget-button)
1653
1654 (defcustom widget-push-button-suffix "]"
1655   "String used as suffix for buttons."
1656   :type 'string
1657   :group 'widget-button)
1658
1659 (define-widget 'push-button 'item
1660   "A pushable button."
1661   :button-prefix ""
1662   :button-suffix ""
1663   :value-create 'widget-push-button-value-create
1664   :format "%[%v%]")
1665
1666 (defun widget-push-button-value-create (widget)
1667   ;; Insert text representing the `on' and `off' states.
1668   (let* ((tag (or (widget-get widget :tag)
1669                   (widget-get widget :value)))
1670          (tag-glyph (widget-get widget :tag-glyph))
1671          (text (concat widget-push-button-prefix
1672                        tag widget-push-button-suffix))
1673          (gui (cdr (assoc tag widget-push-button-cache))))
1674     (cond (tag-glyph
1675            (widget-glyph-insert widget text tag-glyph))
1676           ((and (fboundp 'make-gui-button)
1677              (fboundp 'make-glyph)
1678              widget-push-button-gui
1679              (fboundp 'device-on-window-system-p)
1680              (device-on-window-system-p)
1681              (string-match "XEmacs" emacs-version))
1682            (unless gui
1683              (setq gui (make-gui-button tag 'widget-gui-action widget))
1684              (push (cons tag gui) widget-push-button-cache))
1685            (widget-glyph-insert-glyph widget
1686                                       (make-glyph
1687                                        (list (nth 0 (aref gui 1))
1688                                              (vector 'string ':data text)))
1689                                       (make-glyph
1690                                        (list (nth 1 (aref gui 1))
1691                                              (vector 'string ':data text)))
1692                                       (make-glyph
1693                                        (list (nth 2 (aref gui 1))
1694                                              (vector 'string ':data text)))))
1695           (t
1696            (insert text)))))
1697
1698 (defun widget-gui-action (widget)
1699   "Apply :action for WIDGET."
1700   (widget-apply-action widget (this-command-keys)))
1701
1702 ;;; The `link' Widget.
1703
1704 (defcustom widget-link-prefix "["
1705   "String used as prefix for links."
1706   :type 'string
1707   :group 'widget-button)
1708
1709 (defcustom widget-link-suffix "]"
1710   "String used as suffix for links."
1711   :type 'string
1712   :group 'widget-button)
1713
1714 (define-widget 'link 'item
1715   "An embedded link."
1716   :button-prefix 'widget-link-prefix
1717   :button-suffix 'widget-link-suffix
1718   :help-echo "Follow the link."
1719   :format "%[%t%]")
1720
1721 ;;; The `info-link' Widget.
1722
1723 (define-widget 'info-link 'link
1724   "A link to an info file."
1725   :action 'widget-info-link-action)
1726
1727 (defun widget-info-link-action (widget &optional event)
1728   "Open the info node specified by WIDGET."
1729   (Info-goto-node (widget-value widget)))
1730
1731 ;;; The `url-link' Widget.
1732
1733 (define-widget 'url-link 'link
1734   "A link to an www page."
1735   :action 'widget-url-link-action)
1736
1737 (defun widget-url-link-action (widget &optional event)
1738   "Open the url specified by WIDGET."
1739   (browse-url (widget-value widget)))
1740
1741 ;;; The `function-link' Widget.
1742
1743 (define-widget 'function-link 'link
1744   "A link to an Emacs function."
1745   :action 'widget-function-link-action)
1746
1747 (defun widget-function-link-action (widget &optional event)
1748   "Show the function specified by WIDGET."
1749   (describe-function (widget-value widget)))
1750
1751 ;;; The `variable-link' Widget.
1752
1753 (define-widget 'variable-link 'link
1754   "A link to an Emacs variable."
1755   :action 'widget-variable-link-action)
1756
1757 (defun widget-variable-link-action (widget &optional event)
1758   "Show the variable specified by WIDGET."
1759   (describe-variable (widget-value widget)))
1760
1761 ;;; The `file-link' Widget.
1762
1763 (define-widget 'file-link 'link
1764   "A link to a file."
1765   :action 'widget-file-link-action)
1766
1767 (defun widget-file-link-action (widget &optional event)
1768   "Find the file specified by WIDGET."
1769   (find-file (widget-value widget)))
1770
1771 ;;; The `emacs-library-link' Widget.
1772
1773 (define-widget 'emacs-library-link 'link
1774   "A link to an Emacs Lisp library file."
1775   :action 'widget-emacs-library-link-action)
1776
1777 (defun widget-emacs-library-link-action (widget &optional event)
1778   "Find the Emacs Library file specified by WIDGET."
1779   (find-file (locate-library (widget-value widget))))
1780
1781 ;;; The `emacs-commentary-link' Widget.
1782
1783 (define-widget 'emacs-commentary-link 'link
1784   "A link to Commentary in an Emacs Lisp library file."
1785   :action 'widget-emacs-commentary-link-action)
1786
1787 (defun widget-emacs-commentary-link-action (widget &optional event)
1788   "Find the Commentary section of the Emacs file specified by WIDGET."
1789   (finder-commentary (widget-value widget)))
1790
1791 ;;; The `editable-field' Widget.
1792
1793 (define-widget 'editable-field 'default
1794   "An editable text field."
1795   :convert-widget 'widget-value-convert-widget
1796   :keymap widget-field-keymap
1797   :format "%v"
1798   :value ""
1799   :prompt-internal 'widget-field-prompt-internal
1800   :prompt-history 'widget-field-history
1801   :prompt-value 'widget-field-prompt-value
1802   :action 'widget-field-action
1803   :validate 'widget-field-validate
1804   :valid-regexp ""
1805   :error "No match"
1806   :value-create 'widget-field-value-create
1807   :value-delete 'widget-field-value-delete
1808   :value-get 'widget-field-value-get
1809   :match 'widget-field-match)
1810
1811 (defvar widget-field-history nil
1812   "History of field minibuffer edits.")
1813
1814 (defun widget-field-prompt-internal (widget prompt initial history)
1815   ;; Read string for WIDGET promptinhg with PROMPT.
1816   ;; INITIAL is the initial input and HISTORY is a symbol containing
1817   ;; the earlier input.
1818   (read-string prompt initial history))
1819
1820 (defun widget-field-prompt-value (widget prompt value unbound)
1821   ;; Prompt for a string.
1822   (let ((initial (if unbound
1823                      nil
1824                    (cons (widget-apply widget :value-to-internal
1825                                        value) 0)))
1826         (history (widget-get widget :prompt-history)))
1827     (let ((answer (widget-apply widget
1828                                 :prompt-internal prompt initial history)))
1829       (widget-apply widget :value-to-external answer))))
1830
1831 (defvar widget-edit-functions nil)
1832
1833 (defun widget-field-action (widget &optional event)
1834   ;; Move to next field.
1835   (widget-forward 1)
1836   (run-hook-with-args 'widget-edit-functions widget))
1837
1838 (defun widget-field-validate (widget)
1839   ;; Valid if the content matches `:valid-regexp'.
1840   (save-excursion
1841     (let ((value (widget-apply widget :value-get))
1842           (regexp (widget-get widget :valid-regexp)))
1843       (if (string-match regexp value)
1844           nil
1845         widget))))
1846
1847 (defun widget-field-value-create (widget)
1848   ;; Create an editable text field.
1849   (let ((size (widget-get widget :size))
1850         (value (widget-get widget :value))
1851         (from (point))
1852         ;; This is changed to a real overlay in `widget-setup'.  We
1853         ;; need the end points to behave differently until
1854         ;; `widget-setup' is called.
1855         (overlay (cons (make-marker) (make-marker))))
1856     (widget-put widget :field-overlay overlay)
1857     (insert value)
1858     (and size
1859          (< (length value) size)
1860          (insert-char ?\  (- size (length value))))
1861     (unless (memq widget widget-field-list)
1862       (setq widget-field-new (cons widget widget-field-new)))
1863     (move-marker (cdr overlay) (point))
1864     (set-marker-insertion-type (cdr overlay) nil)
1865     (when (null size)
1866       (insert ?\n))
1867     (move-marker (car overlay) from)
1868     (set-marker-insertion-type (car overlay) t)))
1869
1870 (defun widget-field-value-delete (widget)
1871   ;; Remove the widget from the list of active editing fields.
1872   (setq widget-field-list (delq widget widget-field-list))
1873   ;; These are nil if the :format string doesn't contain `%v'.
1874   (let ((overlay (widget-get widget :field-overlay)))
1875     (when overlay
1876       (delete-overlay overlay))))
1877
1878 (defun widget-field-value-get (widget)
1879   ;; Return current text in editing field.
1880   (let ((from (widget-field-start widget))
1881         (to (widget-field-end widget))
1882         (buffer (widget-field-buffer widget))
1883         (size (widget-get widget :size))
1884         (secret (widget-get widget :secret))
1885         (old (current-buffer)))
1886     (if (and from to)
1887         (progn
1888           (set-buffer buffer)
1889           (while (and size
1890                       (not (zerop size))
1891                       (> to from)
1892                       (eq (char-after (1- to)) ?\ ))
1893             (setq to (1- to)))
1894           (let ((result (buffer-substring-no-properties from to)))
1895             (when secret
1896               (let ((index 0))
1897                 (while (< (+ from index) to)
1898                   (aset result index
1899                         (get-char-property (+ from index) 'secret))
1900                   (setq index (1+ index)))))
1901             (set-buffer old)
1902             result))
1903       (widget-get widget :value))))
1904
1905 (defun widget-field-match (widget value)
1906   ;; Match any string.
1907   (stringp value))
1908
1909 ;;; The `text' Widget.
1910
1911 (define-widget 'text 'editable-field
1912   :keymap widget-text-keymap
1913   "A multiline text area.")
1914
1915 ;;; The `menu-choice' Widget.
1916
1917 (define-widget 'menu-choice 'default
1918   "A menu of options."
1919   :convert-widget  'widget-types-convert-widget
1920   :format "%[%t%]: %v"
1921   :case-fold t
1922   :tag "choice"
1923   :void '(item :format "invalid (%t)\n")
1924   :value-create 'widget-choice-value-create
1925   :value-delete 'widget-children-value-delete
1926   :value-get 'widget-choice-value-get
1927   :value-inline 'widget-choice-value-inline
1928   :default-get 'widget-choice-default-get
1929   :mouse-down-action 'widget-choice-mouse-down-action
1930   :action 'widget-choice-action
1931   :error "Make a choice"
1932   :validate 'widget-choice-validate
1933   :match 'widget-choice-match
1934   :match-inline 'widget-choice-match-inline)
1935
1936 (defun widget-choice-value-create (widget)
1937   ;; Insert the first choice that matches the value.
1938   (let ((value (widget-get widget :value))
1939         (args (widget-get widget :args))
1940         (explicit (widget-get widget :explicit-choice))
1941         (explicit-value (widget-get widget :explicit-choice-value))
1942         current)
1943     (if (and explicit (eq value explicit-value))
1944         (progn
1945           ;; If the user specified the choice for this value,
1946           ;; respect that choice as long as the value is the same.
1947           (widget-put widget :children (list (widget-create-child-value
1948                                               widget explicit value)))
1949           (widget-put widget :choice explicit))
1950       (while args
1951         (setq current (car args)
1952               args (cdr args))
1953         (when (widget-apply current :match value)
1954           (widget-put widget :children (list (widget-create-child-value
1955                                               widget current value)))
1956           (widget-put widget :choice current)
1957           (setq args nil
1958                 current nil)))
1959       (when current
1960         (let ((void (widget-get widget :void)))
1961           (widget-put widget :children (list (widget-create-child-and-convert
1962                                               widget void :value value)))
1963           (widget-put widget :choice void))))))
1964
1965 (defun widget-choice-value-get (widget)
1966   ;; Get value of the child widget.
1967   (widget-value (car (widget-get widget :children))))
1968
1969 (defun widget-choice-value-inline (widget)
1970   ;; Get value of the child widget.
1971   (widget-apply (car (widget-get widget :children)) :value-inline))
1972
1973 (defun widget-choice-default-get (widget)
1974   ;; Get default for the first choice.
1975   (widget-default-get (car (widget-get widget :args))))
1976
1977 (defcustom widget-choice-toggle nil
1978   "If non-nil, a binary choice will just toggle between the values.
1979 Otherwise, the user will explicitly have to choose between the values
1980 when he invoked the menu."
1981   :type 'boolean
1982   :group 'widgets)
1983
1984 (defun widget-choice-mouse-down-action (widget &optional event)
1985   ;; Return non-nil if we need a menu.
1986   (let ((args (widget-get widget :args))
1987         (old (widget-get widget :choice)))
1988     (cond ((not window-system)
1989            ;; No place to pop up a menu.
1990            nil)
1991           ((not (or (fboundp 'x-popup-menu) (fboundp 'popup-menu)))
1992            ;; No way to pop up a menu.
1993            nil)
1994           ((< (length args) 2)
1995            ;; Empty or singleton list, just return the value.
1996            nil)
1997           ((> (length args) widget-menu-max-size)
1998            ;; Too long, prompt.
1999            nil)
2000           ((> (length args) 2)
2001            ;; Reasonable sized list, use menu.
2002            t)
2003           ((and widget-choice-toggle (memq old args))
2004            ;; We toggle.
2005            nil)
2006           (t
2007            ;; Ask which of the two.
2008            t))))
2009
2010 (defun widget-choice-action (widget &optional event)
2011   ;; Make a choice.
2012   (let ((args (widget-get widget :args))
2013         (old (widget-get widget :choice))
2014         (tag (widget-apply widget :menu-tag-get))
2015         (completion-ignore-case (widget-get widget :case-fold))
2016         this-explicit
2017         current choices)
2018     ;; Remember old value.
2019     (if (and old (not (widget-apply widget :validate)))
2020         (let* ((external (widget-value widget))
2021                (internal (widget-apply old :value-to-internal external)))
2022           (widget-put old :value internal)))
2023     ;; Find new choice.
2024     (setq current
2025           (cond ((= (length args) 0)
2026                  nil)
2027                 ((= (length args) 1)
2028                  (nth 0 args))
2029                 ((and widget-choice-toggle
2030                       (= (length args) 2)
2031                       (memq old args))
2032                  (if (eq old (nth 0 args))
2033                      (nth 1 args)
2034                    (nth 0 args)))
2035                 (t
2036                  (while args
2037                    (setq current (car args)
2038                          args (cdr args))
2039                    (setq choices
2040                          (cons (cons (widget-apply current :menu-tag-get)
2041                                      current)
2042                                choices)))
2043                  (setq this-explicit t)
2044                  (widget-choose tag (reverse choices) event))))
2045     (when current
2046       ;; If this was an explicit user choice,
2047       ;; record the choice, and the record the value it was made for.
2048       ;; widget-choice-value-create will respect this choice,
2049       ;; as long as the value is the same.
2050       (when this-explicit
2051         (widget-put widget :explicit-choice current)
2052         (widget-put widget :explicit-choice-value (widget-get widget :value)))
2053       (let ((value (widget-default-get current)))
2054         (widget-value-set widget
2055                           (widget-apply current :value-to-external value)))
2056       (widget-setup)
2057       (widget-apply widget :notify widget event)))
2058   (run-hook-with-args 'widget-edit-functions widget))
2059
2060 (defun widget-choice-validate (widget)
2061   ;; Valid if we have made a valid choice.
2062   (let ((void (widget-get widget :void))
2063         (choice (widget-get widget :choice))
2064         (child (car (widget-get widget :children))))
2065     (if (eq void choice)
2066         widget
2067       (widget-apply child :validate))))
2068
2069 (defun widget-choice-match (widget value)
2070   ;; Matches if one of the choices matches.
2071   (let ((args (widget-get widget :args))
2072         current found)
2073     (while (and args (not found))
2074       (setq current (car args)
2075             args (cdr args)
2076             found (widget-apply current :match value)))
2077     found))
2078
2079 (defun widget-choice-match-inline (widget values)
2080   ;; Matches if one of the choices matches.
2081   (let ((args (widget-get widget :args))
2082         current found)
2083     (while (and args (null found))
2084       (setq current (car args)
2085             args (cdr args)
2086             found (widget-match-inline current values)))
2087     found))
2088
2089 ;;; The `toggle' Widget.
2090
2091 (define-widget 'toggle 'item
2092   "Toggle between two states."
2093   :format "%[%v%]\n"
2094   :value-create 'widget-toggle-value-create
2095   :action 'widget-toggle-action
2096   :match (lambda (widget value) t)
2097   :on "on"
2098   :off "off")
2099
2100 (defun widget-toggle-value-create (widget)
2101   ;; Insert text representing the `on' and `off' states.
2102   (if (widget-value widget)
2103       (widget-glyph-insert widget
2104                            (widget-get widget :on)
2105                            (widget-get widget :on-glyph))
2106     (widget-glyph-insert widget
2107                          (widget-get widget :off)
2108                          (widget-get widget :off-glyph))))
2109
2110 (defun widget-toggle-action (widget &optional event)
2111   ;; Toggle value.
2112   (widget-value-set widget (not (widget-value widget)))
2113   (widget-apply widget :notify widget event)
2114   (run-hook-with-args 'widget-edit-functions widget))
2115
2116 ;;; The `checkbox' Widget.
2117
2118 (define-widget 'checkbox 'toggle
2119   "A checkbox toggle."
2120   :button-suffix ""
2121   :button-prefix ""
2122   :format "%[%v%]"
2123   :on "[X]"
2124   :on-glyph "check1"
2125   :off "[ ]"
2126   :off-glyph "check0"
2127   :action 'widget-checkbox-action)
2128
2129 (defun widget-checkbox-action (widget &optional event)
2130   "Toggle checkbox, notify parent, and set active state of sibling."
2131   (widget-toggle-action widget event)
2132   (let ((sibling (widget-get-sibling widget)))
2133     (when sibling
2134       (if (widget-value widget)
2135           (widget-apply sibling :activate)
2136         (widget-apply sibling :deactivate)))))
2137
2138 ;;; The `checklist' Widget.
2139
2140 (define-widget 'checklist 'default
2141   "A multiple choice widget."
2142   :convert-widget 'widget-types-convert-widget
2143   :format "%v"
2144   :offset 4
2145   :entry-format "%b %v"
2146   :menu-tag "checklist"
2147   :greedy nil
2148   :value-create 'widget-checklist-value-create
2149   :value-delete 'widget-children-value-delete
2150   :value-get 'widget-checklist-value-get
2151   :validate 'widget-checklist-validate
2152   :match 'widget-checklist-match
2153   :match-inline 'widget-checklist-match-inline)
2154
2155 (defun widget-checklist-value-create (widget)
2156   ;; Insert all values
2157   (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
2158         (args (widget-get widget :args)))
2159     (while args
2160       (widget-checklist-add-item widget (car args) (assq (car args) alist))
2161       (setq args (cdr args)))
2162     (widget-put widget :children (nreverse (widget-get widget :children)))))
2163
2164 (defun widget-checklist-add-item (widget type chosen)
2165   ;; Create checklist item in WIDGET of type TYPE.
2166   ;; If the item is checked, CHOSEN is a cons whose cdr is the value.
2167   (and (eq (preceding-char) ?\n)
2168        (widget-get widget :indent)
2169        (insert-char ?  (widget-get widget :indent)))
2170   (widget-specify-insert
2171    (let* ((children (widget-get widget :children))
2172           (buttons (widget-get widget :buttons))
2173           (button-args (or (widget-get type :sibling-args)
2174                            (widget-get widget :button-args)))
2175           (from (point))
2176           child button)
2177      (insert (widget-get widget :entry-format))
2178      (goto-char from)
2179      ;; Parse % escapes in format.
2180      (while (re-search-forward "%\\([bv%]\\)" nil t)
2181        (let ((escape (aref (match-string 1) 0)))
2182          (replace-match "" t t)
2183          (cond ((eq escape ?%)
2184                 (insert "%"))
2185                ((eq escape ?b)
2186                 (setq button (apply 'widget-create-child-and-convert
2187                                     widget 'checkbox
2188                                     :value (not (null chosen))
2189                                     button-args)))
2190                ((eq escape ?v)
2191                 (setq child
2192                       (cond ((not chosen)
2193                              (let ((child (widget-create-child widget type)))
2194                                (widget-apply child :deactivate)
2195                                child))
2196                             ((widget-get type :inline)
2197                              (widget-create-child-value
2198                               widget type (cdr chosen)))
2199                             (t
2200                              (widget-create-child-value
2201                               widget type (car (cdr chosen)))))))
2202                (t
2203                 (error "Unknown escape `%c'" escape)))))
2204      ;; Update properties.
2205      (and button child (widget-put child :button button))
2206      (and button (widget-put widget :buttons (cons button buttons)))
2207      (and child (widget-put widget :children (cons child children))))))
2208
2209 (defun widget-checklist-match (widget values)
2210   ;; All values must match a type in the checklist.
2211   (and (listp values)
2212        (null (cdr (widget-checklist-match-inline widget values)))))
2213
2214 (defun widget-checklist-match-inline (widget values)
2215   ;; Find the values which match a type in the checklist.
2216   (let ((greedy (widget-get widget :greedy))
2217         (args (copy-sequence (widget-get widget :args)))
2218         found rest)
2219     (while values
2220       (let ((answer (widget-checklist-match-up args values)))
2221         (cond (answer
2222                (let ((vals (widget-match-inline answer values)))
2223                  (setq found (append found (car vals))
2224                        values (cdr vals)
2225                        args (delq answer args))))
2226               (greedy
2227                (setq rest (append rest (list (car values)))
2228                      values (cdr values)))
2229               (t
2230                (setq rest (append rest values)
2231                      values nil)))))
2232     (cons found rest)))
2233
2234 (defun widget-checklist-match-find (widget vals)
2235   ;; Find the vals which match a type in the checklist.
2236   ;; Return an alist of (TYPE MATCH).
2237   (let ((greedy (widget-get widget :greedy))
2238         (args (copy-sequence (widget-get widget :args)))
2239         found)
2240     (while vals
2241       (let ((answer (widget-checklist-match-up args vals)))
2242         (cond (answer
2243                (let ((match (widget-match-inline answer vals)))
2244                  (setq found (cons (cons answer (car match)) found)
2245                        vals (cdr match)
2246                        args (delq answer args))))
2247               (greedy
2248                (setq vals (cdr vals)))
2249               (t
2250                (setq vals nil)))))
2251     found))
2252
2253 (defun widget-checklist-match-up (args vals)
2254   ;; Rerturn the first type from ARGS that matches VALS.
2255   (let (current found)
2256     (while (and args (null found))
2257       (setq current (car args)
2258             args (cdr args)
2259             found (widget-match-inline current vals)))
2260     (if found
2261         current
2262       nil)))
2263
2264 (defun widget-checklist-value-get (widget)
2265   ;; The values of all selected items.
2266   (let ((children (widget-get widget :children))
2267         child result)
2268     (while children
2269       (setq child (car children)
2270             children (cdr children))
2271       (if (widget-value (widget-get child :button))
2272           (setq result (append result (widget-apply child :value-inline)))))
2273     result))
2274
2275 (defun widget-checklist-validate (widget)
2276   ;; Ticked chilren must be valid.
2277   (let ((children (widget-get widget :children))
2278         child button found)
2279     (while (and children (not found))
2280       (setq child (car children)
2281             children (cdr children)
2282             button (widget-get child :button)
2283             found (and (widget-value button)
2284                        (widget-apply child :validate))))
2285     found))
2286
2287 ;;; The `option' Widget
2288
2289 (define-widget 'option 'checklist
2290   "An widget with an optional item."
2291   :inline t)
2292
2293 ;;; The `choice-item' Widget.
2294
2295 (define-widget 'choice-item 'item
2296   "Button items that delegate action events to their parents."
2297   :action 'widget-parent-action
2298   :format "%[%t%] \n")
2299
2300 ;;; The `radio-button' Widget.
2301
2302 (define-widget 'radio-button 'toggle
2303   "A radio button for use in the `radio' widget."
2304   :notify 'widget-radio-button-notify
2305   :format "%[%v%]"
2306   :button-suffix ""
2307   :button-prefix ""
2308   :on "(*)"
2309   :on-glyph "radio1"
2310   :off "( )"
2311   :off-glyph "radio0")
2312
2313 (defun widget-radio-button-notify (widget child &optional event)
2314   ;; Tell daddy.
2315   (widget-apply (widget-get widget :parent) :action widget event))
2316
2317 ;;; The `radio-button-choice' Widget.
2318
2319 (define-widget 'radio-button-choice 'default
2320   "Select one of multiple options."
2321   :convert-widget 'widget-types-convert-widget
2322   :offset 4
2323   :format "%v"
2324   :entry-format "%b %v"
2325   :menu-tag "radio"
2326   :value-create 'widget-radio-value-create
2327   :value-delete 'widget-children-value-delete
2328   :value-get 'widget-radio-value-get
2329   :value-inline 'widget-radio-value-inline
2330   :value-set 'widget-radio-value-set
2331   :error "You must push one of the buttons"
2332   :validate 'widget-radio-validate
2333   :match 'widget-choice-match
2334   :match-inline 'widget-choice-match-inline
2335   :action 'widget-radio-action)
2336
2337 (defun widget-radio-value-create (widget)
2338   ;; Insert all values
2339   (let ((args (widget-get widget :args))
2340         arg)
2341     (while args
2342       (setq arg (car args)
2343             args (cdr args))
2344       (widget-radio-add-item widget arg))))
2345
2346 (defun widget-radio-add-item (widget type)
2347   "Add to radio widget WIDGET a new radio button item of type TYPE."
2348   ;; (setq type (widget-convert type))
2349   (and (eq (preceding-char) ?\n)
2350        (widget-get widget :indent)
2351        (insert-char ?  (widget-get widget :indent)))
2352   (widget-specify-insert
2353    (let* ((value (widget-get widget :value))
2354           (children (widget-get widget :children))
2355           (buttons (widget-get widget :buttons))
2356           (button-args (or (widget-get type :sibling-args)
2357                            (widget-get widget :button-args)))
2358           (from (point))
2359           (chosen (and (null (widget-get widget :choice))
2360                        (widget-apply type :match value)))
2361           child button)
2362      (insert (widget-get widget :entry-format))
2363      (goto-char from)
2364      ;; Parse % escapes in format.
2365      (while (re-search-forward "%\\([bv%]\\)" nil t)
2366        (let ((escape (aref (match-string 1) 0)))
2367          (replace-match "" t t)
2368          (cond ((eq escape ?%)
2369                 (insert "%"))
2370                ((eq escape ?b)
2371                 (setq button (apply 'widget-create-child-and-convert
2372                                     widget 'radio-button
2373                                     :value (not (null chosen))
2374                                     button-args)))
2375                ((eq escape ?v)
2376                 (setq child (if chosen
2377                                 (widget-create-child-value
2378                                  widget type value)
2379                               (widget-create-child widget type)))
2380                 (unless chosen
2381                   (widget-apply child :deactivate)))
2382                (t
2383                 (error "Unknown escape `%c'" escape)))))
2384      ;; Update properties.
2385      (when chosen
2386        (widget-put widget :choice type))
2387      (when button
2388        (widget-put child :button button)
2389        (widget-put widget :buttons (nconc buttons (list button))))
2390      (when child
2391        (widget-put widget :children (nconc children (list child))))
2392      child)))
2393
2394 (defun widget-radio-value-get (widget)
2395   ;; Get value of the child widget.
2396   (let ((chosen (widget-radio-chosen widget)))
2397     (and chosen (widget-value chosen))))
2398
2399 (defun widget-radio-chosen (widget)
2400   "Return the widget representing the chosen radio button."
2401   (let ((children (widget-get widget :children))
2402         current found)
2403     (while children
2404       (setq current (car children)
2405             children (cdr children))
2406       (let* ((button (widget-get current :button))
2407              (value (widget-apply button :value-get)))
2408         (when value
2409           (setq found current
2410                 children nil))))
2411     found))
2412
2413 (defun widget-radio-value-inline (widget)
2414   ;; Get value of the child widget.
2415   (let ((children (widget-get widget :children))
2416         current found)
2417     (while children
2418       (setq current (car children)
2419             children (cdr children))
2420       (let* ((button (widget-get current :button))
2421              (value (widget-apply button :value-get)))
2422         (when value
2423           (setq found (widget-apply current :value-inline)
2424                 children nil))))
2425     found))
2426
2427 (defun widget-radio-value-set (widget value)
2428   ;; We can't just delete and recreate a radio widget, since children
2429   ;; can be added after the original creation and won't be recreated
2430   ;; by `:create'.
2431   (let ((children (widget-get widget :children))
2432         current found)
2433     (while children
2434       (setq current (car children)
2435             children (cdr children))
2436       (let* ((button (widget-get current :button))
2437              (match (and (not found)
2438                          (widget-apply current :match value))))
2439         (widget-value-set button match)
2440         (if match
2441             (progn
2442               (widget-value-set current value)
2443               (widget-apply current :activate))
2444           (widget-apply current :deactivate))
2445         (setq found (or found match))))))
2446
2447 (defun widget-radio-validate (widget)
2448   ;; Valid if we have made a valid choice.
2449   (let ((children (widget-get widget :children))
2450         current found button)
2451     (while (and children (not found))
2452       (setq current (car children)
2453             children (cdr children)
2454             button (widget-get current :button)
2455             found (widget-apply button :value-get)))
2456     (if found
2457         (widget-apply current :validate)
2458       widget)))
2459
2460 (defun widget-radio-action (widget child event)
2461   ;; Check if a radio button was pressed.
2462   (let ((children (widget-get widget :children))
2463         (buttons (widget-get widget :buttons))
2464         current)
2465     (when (memq child buttons)
2466       (while children
2467         (setq current (car children)
2468               children (cdr children))
2469         (let* ((button (widget-get current :button)))
2470           (cond ((eq child button)
2471                  (widget-value-set button t)
2472                  (widget-apply current :activate))
2473                 ((widget-value button)
2474                  (widget-value-set button nil)
2475                  (widget-apply current :deactivate)))))))
2476   ;; Pass notification to parent.
2477   (widget-apply widget :notify child event))
2478
2479 ;;; The `insert-button' Widget.
2480
2481 (define-widget 'insert-button 'push-button
2482   "An insert button for the `editable-list' widget."
2483   :tag "INS"
2484   :help-echo "Insert a new item into the list at this position."
2485   :action 'widget-insert-button-action)
2486
2487 (defun widget-insert-button-action (widget &optional event)
2488   ;; Ask the parent to insert a new item.
2489   (widget-apply (widget-get widget :parent)
2490                 :insert-before (widget-get widget :widget)))
2491
2492 ;;; The `delete-button' Widget.
2493
2494 (define-widget 'delete-button 'push-button
2495   "A delete button for the `editable-list' widget."
2496   :tag "DEL"
2497   :help-echo "Delete this item from the list."
2498   :action 'widget-delete-button-action)
2499
2500 (defun widget-delete-button-action (widget &optional event)
2501   ;; Ask the parent to insert a new item.
2502   (widget-apply (widget-get widget :parent)
2503                 :delete-at (widget-get widget :widget)))
2504
2505 ;;; The `editable-list' Widget.
2506
2507 (defcustom widget-editable-list-gui nil
2508   "If non nil, use GUI push-buttons in editable list when available."
2509   :type 'boolean
2510   :group 'widgets)
2511
2512 (define-widget 'editable-list 'default
2513   "A variable list of widgets of the same type."
2514   :convert-widget 'widget-types-convert-widget
2515   :offset 12
2516   :format "%v%i\n"
2517   :format-handler 'widget-editable-list-format-handler
2518   :entry-format "%i %d %v"
2519   :menu-tag "editable-list"
2520   :value-create 'widget-editable-list-value-create
2521   :value-delete 'widget-children-value-delete
2522   :value-get 'widget-editable-list-value-get
2523   :validate 'widget-children-validate
2524   :match 'widget-editable-list-match
2525   :match-inline 'widget-editable-list-match-inline
2526   :insert-before 'widget-editable-list-insert-before
2527   :delete-at 'widget-editable-list-delete-at)
2528
2529 (defun widget-editable-list-format-handler (widget escape)
2530   ;; We recognize the insert button.
2531   (let ((widget-push-button-gui widget-editable-list-gui))
2532     (cond ((eq escape ?i)
2533            (and (widget-get widget :indent)
2534                 (insert-char ?  (widget-get widget :indent)))
2535            (apply 'widget-create-child-and-convert
2536                   widget 'insert-button
2537                   (widget-get widget :append-button-args)))
2538           (t
2539            (widget-default-format-handler widget escape)))))
2540
2541 (defun widget-editable-list-value-create (widget)
2542   ;; Insert all values
2543   (let* ((value (widget-get widget :value))
2544          (type (nth 0 (widget-get widget :args)))
2545          (inlinep (widget-get type :inline))
2546          children)
2547     (widget-put widget :value-pos (copy-marker (point)))
2548     (set-marker-insertion-type (widget-get widget :value-pos) t)
2549     (while value
2550       (let ((answer (widget-match-inline type value)))
2551         (if answer
2552             (setq children (cons (widget-editable-list-entry-create
2553                                   widget
2554                                   (if inlinep
2555                                       (car answer)
2556                                     (car (car answer)))
2557                                   t)
2558                                  children)
2559                   value (cdr answer))
2560           (setq value nil))))
2561     (widget-put widget :children (nreverse children))))
2562
2563 (defun widget-editable-list-value-get (widget)
2564   ;; Get value of the child widget.
2565   (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
2566                          (widget-get widget :children))))
2567
2568 (defun widget-editable-list-match (widget value)
2569   ;; Value must be a list and all the members must match the type.
2570   (and (listp value)
2571        (null (cdr (widget-editable-list-match-inline widget value)))))
2572
2573 (defun widget-editable-list-match-inline (widget value)
2574   (let ((type (nth 0 (widget-get widget :args)))
2575         (ok t)
2576         found)
2577     (while (and value ok)
2578       (let ((answer (widget-match-inline type value)))
2579         (if answer
2580             (setq found (append found (car answer))
2581                   value (cdr answer))
2582           (setq ok nil))))
2583     (cons found value)))
2584
2585 (defun widget-editable-list-insert-before (widget before)
2586   ;; Insert a new child in the list of children.
2587   (save-excursion
2588     (let ((children (widget-get widget :children))
2589           (inhibit-read-only t)
2590           before-change-functions
2591           after-change-functions)
2592       (cond (before
2593              (goto-char (widget-get before :entry-from)))
2594             (t
2595              (goto-char (widget-get widget :value-pos))))
2596       (let ((child (widget-editable-list-entry-create
2597                     widget nil nil)))
2598         (when (< (widget-get child :entry-from) (widget-get widget :from))
2599           (set-marker (widget-get widget :from)
2600                       (widget-get child :entry-from)))
2601         (if (eq (car children) before)
2602             (widget-put widget :children (cons child children))
2603           (while (not (eq (car (cdr children)) before))
2604             (setq children (cdr children)))
2605           (setcdr children (cons child (cdr children)))))))
2606   (widget-setup)
2607   (widget-apply widget :notify widget))
2608
2609 (defun widget-editable-list-delete-at (widget child)
2610   ;; Delete child from list of children.
2611   (save-excursion
2612     (let ((buttons (copy-sequence (widget-get widget :buttons)))
2613           button
2614           (inhibit-read-only t)
2615           before-change-functions
2616           after-change-functions)
2617       (while buttons
2618         (setq button (car buttons)
2619               buttons (cdr buttons))
2620         (when (eq (widget-get button :widget) child)
2621           (widget-put widget
2622                       :buttons (delq button (widget-get widget :buttons)))
2623           (widget-delete button))))
2624     (let ((entry-from (widget-get child :entry-from))
2625           (entry-to (widget-get child :entry-to))
2626           (inhibit-read-only t)
2627           before-change-functions
2628           after-change-functions)
2629       (widget-delete child)
2630       (delete-region entry-from entry-to)
2631       (set-marker entry-from nil)
2632       (set-marker entry-to nil))
2633     (widget-put widget :children (delq child (widget-get widget :children))))
2634   (widget-setup)
2635   (widget-apply widget :notify widget))
2636
2637 (defun widget-editable-list-entry-create (widget value conv)
2638   ;; Create a new entry to the list.
2639   (let ((type (nth 0 (widget-get widget :args)))
2640         (widget-push-button-gui widget-editable-list-gui)
2641         child delete insert)
2642     (widget-specify-insert
2643      (save-excursion
2644        (and (widget-get widget :indent)
2645             (insert-char ?  (widget-get widget :indent)))
2646        (insert (widget-get widget :entry-format)))
2647      ;; Parse % escapes in format.
2648      (while (re-search-forward "%\\(.\\)" nil t)
2649        (let ((escape (aref (match-string 1) 0)))
2650          (replace-match "" t t)
2651          (cond ((eq escape ?%)
2652                 (insert "%"))
2653                ((eq escape ?i)
2654                 (setq insert (apply 'widget-create-child-and-convert
2655                                     widget 'insert-button
2656                                     (widget-get widget :insert-button-args))))
2657                ((eq escape ?d)
2658                 (setq delete (apply 'widget-create-child-and-convert
2659                                     widget 'delete-button
2660                                     (widget-get widget :delete-button-args))))
2661                ((eq escape ?v)
2662                 (if conv
2663                     (setq child (widget-create-child-value
2664                                  widget type value))
2665                   (setq child (widget-create-child-value
2666                                widget type
2667                                (widget-apply type :value-to-external
2668                                              (widget-default-get type))))))
2669                (t
2670                 (error "Unknown escape `%c'" escape)))))
2671      (widget-put widget
2672                  :buttons (cons delete
2673                                 (cons insert
2674                                       (widget-get widget :buttons))))
2675      (let ((entry-from (copy-marker (point-min)))
2676            (entry-to (copy-marker (point-max))))
2677        (set-marker-insertion-type entry-from t)
2678        (set-marker-insertion-type entry-to nil)
2679        (widget-put child :entry-from entry-from)
2680        (widget-put child :entry-to entry-to)))
2681     (widget-put insert :widget child)
2682     (widget-put delete :widget child)
2683     child))
2684
2685 ;;; The `group' Widget.
2686
2687 (define-widget 'group 'default
2688   "A widget which group other widgets inside."
2689   :convert-widget 'widget-types-convert-widget
2690   :format "%v"
2691   :value-create 'widget-group-value-create
2692   :value-delete 'widget-children-value-delete
2693   :value-get 'widget-editable-list-value-get
2694   :default-get 'widget-group-default-get
2695   :validate 'widget-children-validate
2696   :match 'widget-group-match
2697   :match-inline 'widget-group-match-inline)
2698
2699 (defun widget-group-value-create (widget)
2700   ;; Create each component.
2701   (let ((args (widget-get widget :args))
2702         (value (widget-get widget :value))
2703         arg answer children)
2704     (while args
2705       (setq arg (car args)
2706             args (cdr args)
2707             answer (widget-match-inline arg value)
2708             value (cdr answer))
2709       (and (eq (preceding-char) ?\n)
2710            (widget-get widget :indent)
2711            (insert-char ?  (widget-get widget :indent)))
2712       (push (cond ((null answer)
2713                    (widget-create-child widget arg))
2714                   ((widget-get arg :inline)
2715                    (widget-create-child-value widget arg  (car answer)))
2716                   (t
2717                    (widget-create-child-value widget arg  (car (car answer)))))
2718             children))
2719     (widget-put widget :children (nreverse children))))
2720
2721 (defun widget-group-default-get (widget)
2722   ;; Get the default of the components.
2723   (mapcar 'widget-default-get (widget-get widget :args)))
2724
2725 (defun widget-group-match (widget values)
2726   ;; Match if the components match.
2727   (and (listp values)
2728        (let ((match (widget-group-match-inline widget values)))
2729          (and match (null (cdr match))))))
2730
2731 (defun widget-group-match-inline (widget vals)
2732   ;; Match if the components match.
2733   (let ((args (widget-get widget :args))
2734         argument answer found)
2735     (while args
2736       (setq argument (car args)
2737             args (cdr args)
2738             answer (widget-match-inline argument vals))
2739       (if answer
2740           (setq vals (cdr answer)
2741                 found (append found (car answer)))
2742         (setq vals nil
2743               args nil)))
2744     (if answer
2745         (cons found vals)
2746       nil)))
2747
2748 ;;; The `visibility' Widget.
2749
2750 (define-widget 'visibility 'item
2751   "An indicator and manipulator for hidden items."
2752   :format "%[%v%]"
2753   :button-prefix ""
2754   :button-suffix ""
2755   :on "Hide"
2756   :off "Show"
2757   :value-create 'widget-visibility-value-create
2758   :action 'widget-toggle-action
2759   :match (lambda (widget value) t))
2760
2761 (defun widget-visibility-value-create (widget)
2762   ;; Insert text representing the `on' and `off' states.
2763   (let ((on (widget-get widget :on))
2764         (off (widget-get widget :off)))
2765     (if on
2766         (setq on (concat widget-push-button-prefix
2767                          on
2768                          widget-push-button-suffix))
2769       (setq on ""))
2770     (if off
2771         (setq off (concat widget-push-button-prefix
2772                           off
2773                           widget-push-button-suffix))
2774       (setq off ""))
2775     (if (widget-value widget)
2776         (widget-glyph-insert widget on "down" "down-pushed")
2777       (widget-glyph-insert widget off "right" "right-pushed"))))
2778
2779 ;;; The `documentation-link' Widget.
2780 ;;
2781 ;; This is a helper widget for `documentation-string'.
2782
2783 (define-widget 'documentation-link 'link
2784   "Link type used in documentation strings."
2785   :tab-order -1
2786   :help-echo 'widget-documentation-link-echo-help
2787   :action 'widget-documentation-link-action)
2788
2789 (defun widget-documentation-link-echo-help (widget)
2790   "Tell what this link will describe."
2791   (concat "Describe the `" (widget-get widget :value) "' symbol."))
2792
2793 (defun widget-documentation-link-action (widget &optional event)
2794   "Display documentation for WIDGET's value.  Ignore optional argument EVENT."
2795   (let* ((string (widget-get widget :value))
2796          (symbol (intern string)))
2797     (if (and (fboundp symbol) (boundp symbol))
2798         ;; If there are two doc strings, give the user a way to pick one.
2799         (apropos (concat "\\`" (regexp-quote string) "\\'"))
2800       (if (fboundp symbol)
2801           (describe-function symbol)
2802         (describe-variable symbol)))))
2803
2804 (defcustom widget-documentation-links t
2805   "Add hyperlinks to documentation strings when non-nil."
2806   :type 'boolean
2807   :group 'widget-documentation)
2808
2809 (defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'"
2810   "Regexp for matching potential links in documentation strings.
2811 The first group should be the link itself."
2812   :type 'regexp
2813   :group 'widget-documentation)
2814
2815 (defcustom widget-documentation-link-p 'intern-soft
2816   "Predicate used to test if a string is useful as a link.
2817 The value should be a function.  The function will be called one
2818 argument, a string, and should return non-nil if there should be a
2819 link for that string."
2820   :type 'function
2821   :options '(widget-documentation-link-p)
2822   :group 'widget-documentation)
2823
2824 (defcustom widget-documentation-link-type 'documentation-link
2825   "Widget type used for links in documentation strings."
2826   :type 'symbol
2827   :group 'widget-documentation)
2828
2829 (defun widget-documentation-link-add (widget from to)
2830   (widget-specify-doc widget from to)
2831   (when widget-documentation-links
2832     (let ((regexp widget-documentation-link-regexp)
2833           (predicate widget-documentation-link-p)
2834           (type widget-documentation-link-type)
2835           (buttons (widget-get widget :buttons)))
2836       (save-excursion
2837         (goto-char from)
2838         (while (re-search-forward regexp to t)
2839           (let ((name (match-string 1))
2840                 (begin (match-beginning 1))
2841                 (end (match-end 1)))
2842             (when (funcall predicate name)
2843               (push (widget-convert-button type begin end :value name)
2844                     buttons)))))
2845       (widget-put widget :buttons buttons)))
2846   (let ((indent (widget-get widget :indent)))
2847     (when (and indent (not (zerop indent)))
2848       (save-excursion
2849         (save-restriction
2850           (narrow-to-region from to)
2851           (goto-char (point-min))
2852           (while (search-forward "\n" nil t)
2853             (insert-char ?\  indent)))))))
2854
2855 ;;; The `documentation-string' Widget.
2856
2857 (define-widget 'documentation-string 'item
2858   "A documentation string."
2859   :format "%v"
2860   :action 'widget-documentation-string-action
2861   :value-delete 'widget-children-value-delete
2862   :value-create 'widget-documentation-string-value-create)
2863
2864 (defun widget-documentation-string-value-create (widget)
2865   ;; Insert documentation string.
2866   (let ((doc (widget-value widget))
2867         (indent (widget-get widget :indent))
2868         (shown (widget-get (widget-get widget :parent) :documentation-shown))
2869         (start (point)))
2870     (if (string-match "\n" doc)
2871         (let ((before (substring doc 0 (match-beginning 0)))
2872               (after (substring doc (match-beginning 0)))
2873               buttons)
2874           (insert before " ")
2875           (widget-documentation-link-add widget start (point))
2876           (push (widget-create-child-and-convert
2877                  widget 'visibility
2878                  :help-echo "Show or hide rest of the documentation."
2879                  :off "More"
2880                  :action 'widget-parent-action
2881                  shown)
2882                 buttons)
2883           (when shown
2884             (setq start (point))
2885             (when (and indent (not (zerop indent)))
2886               (insert-char ?\  indent))
2887             (insert after)
2888             (widget-documentation-link-add widget start (point)))
2889           (widget-put widget :buttons buttons))
2890       (insert doc)
2891       (widget-documentation-link-add widget start (point))))
2892   (insert "\n"))
2893
2894 (defun widget-documentation-string-action (widget &rest ignore)
2895   ;; Toggle documentation.
2896   (let ((parent (widget-get widget :parent)))
2897     (widget-put parent :documentation-shown
2898                 (not (widget-get parent :documentation-shown))))
2899   ;; Redraw.
2900   (widget-value-set widget (widget-value widget)))
2901
2902 ;;; The Sexp Widgets.
2903
2904 (define-widget 'const 'item
2905   "An immutable sexp."
2906   :prompt-value 'widget-const-prompt-value
2907   :format "%t\n%d")
2908
2909 (defun widget-const-prompt-value (widget prompt value unbound)
2910   ;; Return the value of the const.
2911   (widget-value widget))
2912
2913 (define-widget 'function-item 'const
2914   "An immutable function name."
2915   :format "%v\n%h"
2916   :documentation-property (lambda (symbol)
2917                             (condition-case nil
2918                                 (documentation symbol t)
2919                               (error nil))))
2920
2921 (define-widget 'variable-item 'const
2922   "An immutable variable name."
2923   :format "%v\n%h"
2924   :documentation-property 'variable-documentation)
2925
2926 (define-widget 'other 'sexp
2927   "Matches any value, but doesn't let the user edit the value.
2928 This is useful as last item in a `choice' widget.
2929 You should use this widget type with a default value,
2930 as in (other DEFAULT) or (other :tag \"NAME\" DEFAULT).
2931 If the user selects this alternative, that specifies DEFAULT
2932 as the value."
2933   :tag "Other"
2934   :format "%t%n"
2935   :value 'other)
2936
2937 (defvar widget-string-prompt-value-history nil
2938   "History of input to `widget-string-prompt-value'.")
2939
2940 (define-widget 'string 'editable-field
2941   "A string"
2942   :tag "String"
2943   :format "%{%t%}: %v"
2944   :complete-function 'ispell-complete-word
2945   :prompt-history 'widget-string-prompt-value-history)
2946
2947 (define-widget 'regexp 'string
2948   "A regular expression."
2949   :match 'widget-regexp-match
2950   :validate 'widget-regexp-validate
2951   ;; Doesn't work well with terminating newline.
2952   ;; :value-face 'widget-single-line-field-face
2953   :tag "Regexp")
2954
2955 (defun widget-regexp-match (widget value)
2956   ;; Match valid regexps.
2957   (and (stringp value)
2958        (condition-case nil
2959            (prog1 t
2960              (string-match value ""))
2961          (error nil))))
2962
2963 (defun widget-regexp-validate (widget)
2964   "Check that the value of WIDGET is a valid regexp."
2965   (let ((val (widget-value widget)))
2966     (condition-case data
2967         (prog1 nil
2968           (string-match val ""))
2969       (error (widget-put widget :error (error-message-string data))
2970              widget))))
2971
2972 (define-widget 'file 'string
2973   "A file widget.
2974 It will read a file name from the minibuffer when invoked."
2975   :complete-function 'widget-file-complete
2976   :prompt-value 'widget-file-prompt-value
2977   :format "%{%t%}: %v"
2978   ;; Doesn't work well with terminating newline.
2979   ;; :value-face 'widget-single-line-field-face
2980   :tag "File")
2981
2982 (defun widget-file-complete ()
2983   "Perform completion on file name preceding point."
2984   (interactive)
2985   (let* ((end (point))
2986          (beg (save-excursion
2987                 (skip-chars-backward "^ ")
2988                 (point)))
2989          (pattern (buffer-substring beg end))
2990          (name-part (file-name-nondirectory pattern))
2991          (directory (file-name-directory pattern))
2992          (completion (file-name-completion name-part directory)))
2993     (cond ((eq completion t))
2994           ((null completion)
2995            (message "Can't find completion for \"%s\"" pattern)
2996            (ding))
2997           ((not (string= name-part completion))
2998            (delete-region beg end)
2999            (insert (expand-file-name completion directory)))
3000           (t
3001            (message "Making completion list...")
3002            (let ((list (file-name-all-completions name-part directory)))
3003              (setq list (sort list 'string<))
3004              (with-output-to-temp-buffer "*Completions*"
3005                (display-completion-list list)))
3006            (message "Making completion list...%s" "done")))))
3007
3008 (defun widget-file-prompt-value (widget prompt value unbound)
3009   ;; Read file from minibuffer.
3010   (abbreviate-file-name
3011    (if unbound
3012        (read-file-name prompt)
3013      (let ((prompt2 (format "%s (default %s) " prompt value))
3014            (dir (file-name-directory value))
3015            (file (file-name-nondirectory value))
3016            (must-match (widget-get widget :must-match)))
3017        (read-file-name prompt2 dir nil must-match file)))))
3018
3019 ;;;(defun widget-file-action (widget &optional event)
3020 ;;;  ;; Read a file name from the minibuffer.
3021 ;;;  (let* ((value (widget-value widget))
3022 ;;;      (dir (file-name-directory value))
3023 ;;;      (file (file-name-nondirectory value))
3024 ;;;      (menu-tag (widget-apply widget :menu-tag-get))
3025 ;;;      (must-match (widget-get widget :must-match))
3026 ;;;      (answer (read-file-name (concat menu-tag ": (default `" value "') ")
3027 ;;;                              dir nil must-match file)))
3028 ;;;    (widget-value-set widget (abbreviate-file-name answer))
3029 ;;;    (widget-setup)
3030 ;;;    (widget-apply widget :notify widget event)))
3031
3032 (define-widget 'directory 'file
3033   "A directory widget.
3034 It will read a directory name from the minibuffer when invoked."
3035   :tag "Directory")
3036
3037 (defvar widget-symbol-prompt-value-history nil
3038   "History of input to `widget-symbol-prompt-value'.")
3039
3040 (define-widget 'symbol 'editable-field
3041   "A Lisp symbol."
3042   :value nil
3043   :tag "Symbol"
3044   :format "%{%t%}: %v"
3045   :match (lambda (widget value) (symbolp value))
3046   :complete-function 'lisp-complete-symbol
3047   :prompt-internal 'widget-symbol-prompt-internal
3048   :prompt-match 'symbolp
3049   :prompt-history 'widget-symbol-prompt-value-history
3050   :value-to-internal (lambda (widget value)
3051                        (if (symbolp value)
3052                            (symbol-name value)
3053                          value))
3054   :value-to-external (lambda (widget value)
3055                        (if (stringp value)
3056                            (intern value)
3057                          value)))
3058
3059 (defun widget-symbol-prompt-internal (widget prompt initial history)
3060   ;; Read file from minibuffer.
3061   (let ((answer (completing-read prompt obarray
3062                                  (widget-get widget :prompt-match)
3063                                  nil initial history)))
3064     (if (and (stringp answer)
3065              (not (zerop (length answer))))
3066         answer
3067       (error "No value"))))
3068
3069 (defvar widget-function-prompt-value-history nil
3070   "History of input to `widget-function-prompt-value'.")
3071
3072 (define-widget 'function 'sexp
3073   "A Lisp function."
3074   :complete-function 'lisp-complete-symbol
3075   :prompt-value 'widget-field-prompt-value
3076   :prompt-internal 'widget-symbol-prompt-internal
3077   :prompt-match 'fboundp
3078   :prompt-history 'widget-function-prompt-value-history
3079   :action 'widget-field-action
3080   :tag "Function")
3081
3082 (defvar widget-variable-prompt-value-history nil
3083   "History of input to `widget-variable-prompt-value'.")
3084
3085 (define-widget 'variable 'symbol
3086   ;; Should complete on variables.
3087   "A Lisp variable."
3088   :prompt-match 'boundp
3089   :prompt-history 'widget-variable-prompt-value-history
3090   :tag "Variable")
3091
3092 (when (featurep 'mule)
3093   (defvar widget-coding-system-prompt-value-history nil
3094     "History of input to `widget-coding-system-prompt-value'.")
3095
3096   (define-widget 'coding-system 'symbol
3097     "A MULE coding-system."
3098     :format "%{%t%}: %v"
3099     :tag "Coding system"
3100     :prompt-history 'widget-coding-system-prompt-value-history
3101     :prompt-value 'widget-coding-system-prompt-value
3102     :action 'widget-coding-system-action)
3103
3104   (defun widget-coding-system-prompt-value (widget prompt value unbound)
3105     ;; Read coding-system from minibuffer.
3106     (intern
3107      (completing-read (format "%s (default %s) " prompt value)
3108                       (mapcar (function
3109                                (lambda (sym)
3110                                  (list (symbol-name sym))
3111                                  ))
3112                               (coding-system-list)))))
3113
3114   (defun widget-coding-system-action (widget &optional event)
3115     ;; Read a file name from the minibuffer.
3116     (let ((answer
3117            (widget-coding-system-prompt-value
3118             widget
3119             (widget-apply widget :menu-tag-get)
3120             (widget-value widget)
3121             t)))
3122       (widget-value-set widget answer)
3123       (widget-apply widget :notify widget event)
3124       (widget-setup)))
3125   )
3126
3127 (define-widget 'sexp 'editable-field
3128   "An arbitrary Lisp expression."
3129   :tag "Lisp expression"
3130   :format "%{%t%}: %v"
3131   :value nil
3132   :validate 'widget-sexp-validate
3133   :match (lambda (widget value) t)
3134   :value-to-internal 'widget-sexp-value-to-internal
3135   :value-to-external (lambda (widget value) (read value))
3136   :prompt-history 'widget-sexp-prompt-value-history
3137   :prompt-value 'widget-sexp-prompt-value)
3138
3139 (defun widget-sexp-value-to-internal (widget value)
3140   ;; Use pp for printer representation.
3141   (let ((pp (if (symbolp value)
3142                 (prin1-to-string value)
3143               (pp-to-string value))))
3144     (while (string-match "\n\\'" pp)
3145       (setq pp (substring pp 0 -1)))
3146     (if (or (string-match "\n\\'" pp)
3147             (> (length pp) 40))
3148         (concat "\n" pp)
3149       pp)))
3150
3151 (defun widget-sexp-validate (widget)
3152   ;; Valid if we can read the string and there is no junk left after it.
3153   (save-excursion
3154     (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
3155       (erase-buffer)
3156       (insert (widget-apply widget :value-get))
3157       (goto-char (point-min))
3158       (condition-case data
3159           (let ((value (read buffer)))
3160             (if (eobp)
3161                 (if (widget-apply widget :match value)
3162                     nil
3163                   (widget-put widget :error (widget-get widget :type-error))
3164                   widget)
3165               (widget-put widget
3166                           :error (format "Junk at end of expression: %s"
3167                                          (buffer-substring (point)
3168                                                            (point-max))))
3169               widget))
3170         (error (widget-put widget :error (error-message-string data))
3171                widget)))))
3172
3173 (defvar widget-sexp-prompt-value-history nil
3174   "History of input to `widget-sexp-prompt-value'.")
3175
3176 (defun widget-sexp-prompt-value (widget prompt value unbound)
3177   ;; Read an arbitrary sexp.
3178   (let ((found (read-string prompt
3179                             (if unbound nil (cons (prin1-to-string value) 0))
3180                             (widget-get widget :prompt-history))))
3181     (save-excursion
3182       (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
3183         (erase-buffer)
3184         (insert found)
3185         (goto-char (point-min))
3186         (let ((answer (read buffer)))
3187           (unless (eobp)
3188             (error "Junk at end of expression: %s"
3189                    (buffer-substring (point) (point-max))))
3190           answer)))))
3191
3192 (define-widget 'restricted-sexp 'sexp
3193   "A Lisp expression restricted to values that match.
3194 To use this type, you must define :match or :match-alternatives."
3195   :type-error "The specified value is not valid"
3196   :match 'widget-restricted-sexp-match
3197   :value-to-internal (lambda (widget value)
3198                        (if (widget-apply widget :match value)
3199                            (prin1-to-string value)
3200                          value)))
3201
3202 (defun widget-restricted-sexp-match (widget value)
3203   (let ((alternatives (widget-get widget :match-alternatives))
3204         matched)
3205     (while (and alternatives (not matched))
3206       (if (cond ((functionp (car alternatives))
3207                  (funcall (car alternatives) value))
3208                 ((and (consp (car alternatives))
3209                       (eq (car (car alternatives)) 'quote))
3210                  (eq value (nth 1 (car alternatives)))))
3211           (setq matched t))
3212       (setq alternatives (cdr alternatives)))
3213     matched))
3214
3215 (define-widget 'integer 'restricted-sexp
3216   "An integer."
3217   :tag "Integer"
3218   :value 0
3219   :type-error "This field should contain an integer"
3220   :match-alternatives '(integerp))
3221
3222 (define-widget 'number 'restricted-sexp
3223   "A floating point number."
3224   :tag "Number"
3225   :value 0.0
3226   :type-error "This field should contain a number"
3227   :match-alternatives '(numberp))
3228
3229 (define-widget 'character 'editable-field
3230   "A character."
3231   :tag "Character"
3232   :value 0
3233   :size 1
3234   :format "%{%t%}: %v\n"
3235   :valid-regexp "\\`.\\'"
3236   :error "This field should contain a single character"
3237   :value-to-internal (lambda (widget value)
3238                        (if (stringp value)
3239                            value
3240                          (char-to-string value)))
3241   :value-to-external (lambda (widget value)
3242                        (if (stringp value)
3243                            (aref value 0)
3244                          value))
3245   :match (lambda (widget value)
3246            (if (fboundp 'characterp)
3247                (characterp value)
3248              (integerp value))))
3249
3250 (define-widget 'list 'group
3251   "A Lisp list."
3252   :tag "List"
3253   :format "%{%t%}:\n%v")
3254
3255 (define-widget 'vector 'group
3256   "A Lisp vector."
3257   :tag "Vector"
3258   :format "%{%t%}:\n%v"
3259   :match 'widget-vector-match
3260   :value-to-internal (lambda (widget value) (append value nil))
3261   :value-to-external (lambda (widget value) (apply 'vector value)))
3262
3263 (defun widget-vector-match (widget value)
3264   (and (vectorp value)
3265        (widget-group-match widget
3266                            (widget-apply widget :value-to-internal value))))
3267
3268 (define-widget 'cons 'group
3269   "A cons-cell."
3270   :tag "Cons-cell"
3271   :format "%{%t%}:\n%v"
3272   :match 'widget-cons-match
3273   :value-to-internal (lambda (widget value)
3274                        (list (car value) (cdr value)))
3275   :value-to-external (lambda (widget value)
3276                        (cons (nth 0 value) (nth 1 value))))
3277
3278 (defun widget-cons-match (widget value)
3279   (and (consp value)
3280        (widget-group-match widget
3281                            (widget-apply widget :value-to-internal value))))
3282
3283 (define-widget 'choice 'menu-choice
3284   "A union of several sexp types."
3285   :tag "Choice"
3286   :format "%{%t%}: %[Value Menu%] %v"
3287   :button-prefix 'widget-push-button-prefix
3288   :button-suffix 'widget-push-button-suffix
3289   :prompt-value 'widget-choice-prompt-value)
3290
3291 (defun widget-choice-prompt-value (widget prompt value unbound)
3292   "Make a choice."
3293   (let ((args (widget-get widget :args))
3294         (completion-ignore-case (widget-get widget :case-fold))
3295         current choices old)
3296     ;; Find the first arg that match VALUE.
3297     (let ((look args))
3298       (while look
3299         (if (widget-apply (car look) :match value)
3300             (setq old (car look)
3301                   look nil)
3302           (setq look (cdr look)))))
3303     ;; Find new choice.
3304     (setq current
3305           (cond ((= (length args) 0)
3306                  nil)
3307                 ((= (length args) 1)
3308                  (nth 0 args))
3309                 ((and (= (length args) 2)
3310                       (memq old args))
3311                  (if (eq old (nth 0 args))
3312                      (nth 1 args)
3313                    (nth 0 args)))
3314                 (t
3315                  (while args
3316                    (setq current (car args)
3317                          args (cdr args))
3318                    (setq choices
3319                          (cons (cons (widget-apply current :menu-tag-get)
3320                                      current)
3321                                choices)))
3322                  (let ((val (completing-read prompt choices nil t)))
3323                    (if (stringp val)
3324                        (let ((try (try-completion val choices)))
3325                          (when (stringp try)
3326                            (setq val try))
3327                          (cdr (assoc val choices)))
3328                      nil)))))
3329     (if current
3330         (widget-prompt-value current prompt nil t)
3331       value)))
3332
3333 (define-widget 'radio 'radio-button-choice
3334   "A union of several sexp types."
3335   :tag "Choice"
3336   :format "%{%t%}:\n%v"
3337   :prompt-value 'widget-choice-prompt-value)
3338
3339 (define-widget 'repeat 'editable-list
3340   "A variable length homogeneous list."
3341   :tag "Repeat"
3342   :format "%{%t%}:\n%v%i\n")
3343
3344 (define-widget 'set 'checklist
3345   "A list of members from a fixed set."
3346   :tag "Set"
3347   :format "%{%t%}:\n%v")
3348
3349 (define-widget 'boolean 'toggle
3350   "To be nil or non-nil, that is the question."
3351   :tag "Boolean"
3352   :prompt-value 'widget-boolean-prompt-value
3353   :button-prefix 'widget-push-button-prefix
3354   :button-suffix 'widget-push-button-suffix
3355   :format "%{%t%}: %[Toggle%]  %v\n"
3356   :on "on (non-nil)"
3357   :off "off (nil)")
3358
3359 (defun widget-boolean-prompt-value (widget prompt value unbound)
3360   ;; Toggle a boolean.
3361   (y-or-n-p prompt))
3362
3363 ;;; The `color' Widget.
3364
3365 (define-widget 'color 'editable-field
3366   "Choose a color name (with sample)."
3367   :format "%t: %v (%{sample%})\n"
3368   :size 10
3369   :tag "Color"
3370   :value "black"
3371   :complete 'widget-color-complete
3372   :sample-face-get 'widget-color-sample-face-get
3373   :notify 'widget-color-notify
3374   :action 'widget-color-action)
3375
3376 (defun widget-color-complete (widget)
3377   "Complete the color in WIDGET."
3378   (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
3379                                                  (point)))
3380          (list (widget-color-choice-list))
3381          (completion (try-completion prefix list)))
3382     (cond ((eq completion t)
3383            (message "Exact match."))
3384           ((null completion)
3385            (error "Can't find completion for \"%s\"" prefix))
3386           ((not (string-equal prefix completion))
3387            (insert-and-inherit (substring completion (length prefix))))
3388           (t
3389            (message "Making completion list...")
3390            (let ((list (all-completions prefix list nil)))
3391              (with-output-to-temp-buffer "*Completions*"
3392                (display-completion-list list)))
3393            (message "Making completion list...done")))))
3394
3395 (defun widget-color-sample-face-get (widget)
3396   (let* ((value (condition-case nil
3397                     (widget-value widget)
3398                   (error (widget-get widget :value))))
3399          (symbol (intern (concat "fg:" value))))
3400     (condition-case nil
3401         (facemenu-get-face symbol)
3402       (error 'default))))
3403
3404 (defvar widget-color-choice-list nil)
3405 ;; Variable holding the possible colors.
3406
3407 (defun widget-color-choice-list ()
3408   (unless widget-color-choice-list
3409     (setq widget-color-choice-list
3410           (mapcar '(lambda (color) (list color))
3411                   (x-defined-colors))))
3412   widget-color-choice-list)
3413
3414 (defvar widget-color-history nil
3415   "History of entered colors")
3416
3417 (defun widget-color-action (widget &optional event)
3418   ;; Prompt for a color.
3419   (let* ((tag (widget-apply widget :menu-tag-get))
3420          (prompt (concat tag ": "))
3421          (value (widget-value widget))
3422          (start (widget-field-start widget))
3423          (pos (cond ((< (point) start)
3424                      0)
3425                     ((> (point) (+ start (length value)))
3426                      (length value))
3427                     (t
3428                      (- (point) start))))
3429          (answer (if (commandp 'read-color)
3430                      (read-color prompt)
3431                    (completing-read (concat tag ": ")
3432                                     (widget-color-choice-list)
3433                                     nil nil
3434                                     (cons value pos)
3435                                     'widget-color-history))))
3436     (unless (zerop (length answer))
3437       (widget-value-set widget answer)
3438       (widget-setup)
3439       (widget-apply widget :notify widget event))))
3440
3441 (defun widget-color-notify (widget child &optional event)
3442   "Update the sample, and notofy the parent."
3443   (overlay-put (widget-get widget :sample-overlay)
3444                'face (widget-apply widget :sample-face-get))
3445   (widget-default-notify widget child event))
3446
3447 ;;; The Help Echo
3448
3449 (defun widget-echo-help-mouse ()
3450   "Display the help message for the widget under the mouse.
3451 Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"
3452   (let* ((pos (mouse-position))
3453          (frame (car pos))
3454          (x (car (cdr pos)))
3455          (y (cdr (cdr pos)))
3456          (win (window-at x y frame))
3457          (where (coordinates-in-window-p (cons x y) win)))
3458     (when (consp where)
3459       (save-window-excursion
3460         (progn ; save-excursion
3461           (select-window win)
3462           (let* ((result (compute-motion (window-start win)
3463                                          '(0 . 0)
3464                                          (point-max)
3465                                          where
3466                                          (window-width win)
3467                                          (cons (window-hscroll) 0)
3468                                          win)))
3469             (when (and (eq (nth 1 result) x)
3470                        (eq (nth 2 result) y))
3471               (widget-echo-help (nth 0 result))))))))
3472   (unless track-mouse
3473     (setq track-mouse t)
3474     (add-hook 'post-command-hook 'widget-stop-mouse-tracking)))
3475
3476 (defun widget-stop-mouse-tracking (&rest args)
3477   "Stop the mouse tracking done while idle."
3478   (remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
3479   (setq track-mouse nil))
3480
3481 (defun widget-at (pos)
3482   "The button or field at POS."
3483   (or (get-char-property pos 'button)
3484       (get-char-property pos 'field)))
3485
3486 (defun widget-echo-help (pos)
3487   "Display the help echo for widget at POS."
3488   (let* ((widget (widget-at pos))
3489          (help-echo (and widget (widget-get widget :help-echo))))
3490     (cond ((stringp help-echo)
3491            (message "%s" help-echo))
3492           ((and (symbolp help-echo) (fboundp help-echo)
3493                 (stringp (setq help-echo (funcall help-echo widget))))
3494            (message "%s" help-echo)))))
3495
3496 ;;; The End:
3497
3498 (provide 'wid-edit)
3499
3500 ;; wid-edit.el ends here