lisp/wid-edit.el

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