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
2166 ;;; The `checklist' Widget.
2167
2168 (define-widget 'checklist 'default
2169   "A multiple choice widget."
2170   :convert-widget 'widget-types-convert-widget
2171   :copy 'widget-types-copy
2172   :format "%v"
2173   :offset 4
2174   :entry-format "%b %v"
2175   :greedy nil
2176   :value-create 'widget-checklist-value-create
2177   :value-get 'widget-checklist-value-get
2178   :validate 'widget-checklist-validate
2179   :match 'widget-checklist-match
2180   :match-inline 'widget-checklist-match-inline)
2181
2182 (defun widget-checklist-value-create (widget)
2183   ;; Insert all values
2184   (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
2185         (args (widget-get widget :args)))
2186     (while args
2187       (widget-checklist-add-item widget (car args) (assq (car args) alist))
2188       (setq args (cdr args)))
2189     (widget-put widget :children (nreverse (widget-get widget :children)))))
2190
2191 (defun widget-checklist-add-item (widget type chosen)
2192   "Create checklist item in WIDGET of type TYPE.
2193 If the item is checked, CHOSEN is a cons whose cdr is the value."
2194   (and (eq (preceding-char) ?\n)
2195        (widget-get widget :indent)
2196        (insert-char ?\s (widget-get widget :indent)))
2197   (widget-specify-insert
2198    (let* ((children (widget-get widget :children))
2199           (buttons (widget-get widget :buttons))
2200           (button-args (or (widget-get type :sibling-args)
2201                            (widget-get widget :button-args)))
2202           (from (point))
2203           child button)
2204      (insert (widget-get widget :entry-format))
2205      (goto-char from)
2206      ;; Parse % escapes in format.
2207      (while (re-search-forward "%\\([bv%]\\)" nil t)
2208        (let ((escape (char-after (match-beginning 1))))
2209          (delete-backward-char 2)
2210          (cond ((eq escape ?%)
2211                 (insert ?%))
2212                ((eq escape ?b)
2213                 (setq button (apply 'widget-create-child-and-convert
2214                                     widget 'checkbox
2215                                     :value (not (null chosen))
2216                                     button-args)))
2217                ((eq escape ?v)
2218                 (setq child
2219                       (cond ((not chosen)
2220                              (let ((child (widget-create-child widget type)))
2221                                (widget-apply child :deactivate)
2222                                child))
2223                             ((widget-get type :inline)
2224                              (widget-create-child-value
2225                               widget type (cdr chosen)))
2226                             (t
2227                              (widget-create-child-value
2228                               widget type (car (cdr chosen)))))))
2229                (t
2230                 (error "Unknown escape `%c'" escape)))))
2231      ;; Update properties.
2232      (and button child (widget-put child :button button))
2233      (and button (widget-put widget :buttons (cons button buttons)))
2234      (and child (widget-put widget :children (cons child children))))))
2235
2236 (defun widget-checklist-match (widget values)
2237   ;; All values must match a type in the checklist.
2238   (and (listp values)
2239        (null (cdr (widget-checklist-match-inline widget values)))))
2240
2241 (defun widget-checklist-match-inline (widget values)
2242   ;; Find the values which match a type in the checklist.
2243   (let ((greedy (widget-get widget :greedy))
2244         (args (copy-sequence (widget-get widget :args)))
2245         found rest)
2246     (while values
2247       (let ((answer (widget-checklist-match-up args values)))
2248         (cond (answer
2249                (let ((vals (widget-match-inline answer values)))
2250                  (setq found (append found (car vals))
2251                        values (cdr vals)
2252                        args (delq answer args))))
2253               (greedy
2254                (setq rest (append rest (list (car values)))
2255                      values (cdr values)))
2256               (t
2257                (setq rest (append rest values)
2258                      values nil)))))
2259     (cons found rest)))
2260
2261 (defun widget-checklist-match-find (widget vals)
2262   "Find the vals which match a type in the checklist.
2263 Return an alist of (TYPE MATCH)."
2264   (let ((greedy (widget-get widget :greedy))
2265         (args (copy-sequence (widget-get widget :args)))
2266         found)
2267     (while vals
2268       (let ((answer (widget-checklist-match-up args vals)))
2269         (cond (answer
2270                (let ((match (widget-match-inline answer vals)))
2271                  (setq found (cons (cons answer (car match)) found)
2272                        vals (cdr match)
2273                        args (delq answer args))))
2274               (greedy
2275                (setq vals (cdr vals)))
2276               (t
2277                (setq vals nil)))))
2278     found))
2279
2280 (defun widget-checklist-match-up (args vals)
2281   "Return the first type from ARGS that matches VALS."
2282   (let (current found)
2283     (while (and args (null found))
2284       (setq current (car args)
2285             args (cdr args)
2286             found (widget-match-inline current vals)))
2287     (if found
2288         current)))
2289
2290 (defun widget-checklist-value-get (widget)
2291   ;; The values of all selected items.
2292   (let ((children (widget-get widget :children))
2293         child result)
2294     (while children
2295       (setq child (car children)
2296             children (cdr children))
2297       (if (widget-value (widget-get child :button))
2298           (setq result (append result (widget-apply child :value-inline)))))
2299     result))
2300
2301 (defun widget-checklist-validate (widget)
2302   ;; Ticked chilren must be valid.
2303   (let ((children (widget-get widget :children))
2304         child button found)
2305     (while (and children (not found))
2306       (setq child (car children)
2307             children (cdr children)
2308             button (widget-get child :button)
2309             found (and (widget-value button)
2310                        (widget-apply child :validate))))
2311     found))
2312
2313 ;;; The `option' Widget
2314
2315 (define-widget 'option 'checklist
2316   "An widget with an optional item."
2317   :inline t)
2318
2319 ;;; The `choice-item' Widget.
2320
2321 (define-widget 'choice-item 'item
2322   "Button items that delegate action events to their parents."
2323   :action 'widget-parent-action
2324   :format "%[%t%] \n")
2325
2326 ;;; The `radio-button' Widget.
2327
2328 (define-widget 'radio-button 'toggle
2329   "A radio button for use in the `radio' widget."
2330   :notify 'widget-radio-button-notify
2331   :format "%[%v%]"
2332   :button-suffix ""
2333   :button-prefix ""
2334   :on "(*)"
2335   :on-glyph "radio1"
2336   :off "( )"
2337   :off-glyph "radio0")
2338
2339 (defun widget-radio-button-notify (widget child &optional event)
2340   ;; Tell daddy.
2341   (widget-apply (widget-get widget :parent) :action widget event))
2342
2343 ;;; The `radio-button-choice' Widget.
2344
2345 (define-widget 'radio-button-choice 'default
2346   "Select one of multiple options."
2347   :convert-widget 'widget-types-convert-widget
2348   :copy 'widget-types-copy
2349   :offset 4
2350   :format "%v"
2351   :entry-format "%b %v"
2352   :value-create 'widget-radio-value-create
2353   :value-get 'widget-radio-value-get
2354   :value-inline 'widget-radio-value-inline
2355   :value-set 'widget-radio-value-set
2356   :error "You must push one of the buttons"
2357   :validate 'widget-radio-validate
2358   :match 'widget-choice-match
2359   :match-inline 'widget-choice-match-inline
2360   :action 'widget-radio-action)
2361
2362 (defun widget-radio-value-create (widget)
2363   ;; Insert all values
2364   (let ((args (widget-get widget :args))
2365         arg)
2366     (while args
2367       (setq arg (car args)
2368             args (cdr args))
2369       (widget-radio-add-item widget arg))))
2370
2371 (defun widget-radio-add-item (widget type)
2372   "Add to radio widget WIDGET a new radio button item of type TYPE."
2373   ;; (setq type (widget-convert type))
2374   (and (eq (preceding-char) ?\n)
2375        (widget-get widget :indent)
2376        (insert-char ?\s (widget-get widget :indent)))
2377   (widget-specify-insert
2378    (let* ((value (widget-get widget :value))
2379           (children (widget-get widget :children))
2380           (buttons (widget-get widget :buttons))
2381           (button-args (or (widget-get type :sibling-args)
2382                            (widget-get widget :button-args)))
2383           (from (point))
2384           (chosen (and (null (widget-get widget :choice))
2385                        (widget-apply type :match value)))
2386           child button)
2387      (insert (widget-get widget :entry-format))
2388      (goto-char from)
2389      ;; Parse % escapes in format.
2390      (while (re-search-forward "%\\([bv%]\\)" nil t)
2391        (let ((escape (char-after (match-beginning 1))))
2392          (delete-backward-char 2)
2393          (cond ((eq escape ?%)
2394                 (insert ?%))
2395                ((eq escape ?b)
2396                 (setq button (apply 'widget-create-child-and-convert
2397                                     widget 'radio-button
2398                                     :value (not (null chosen))
2399                                     button-args)))
2400                ((eq escape ?v)
2401                 (setq child (if chosen
2402                                 (widget-create-child-value
2403                                  widget type value)
2404                               (widget-create-child widget type)))
2405                 (unless chosen
2406                   (widget-apply child :deactivate)))
2407                (t
2408                 (error "Unknown escape `%c'" escape)))))
2409      ;; Update properties.
2410      (when chosen
2411        (widget-put widget :choice type))
2412      (when button
2413        (widget-put child :button button)
2414        (widget-put widget :buttons (nconc buttons (list button))))
2415      (when child
2416        (widget-put widget :children (nconc children (list child))))
2417      child)))
2418
2419 (defun widget-radio-value-get (widget)
2420   ;; Get value of the child widget.
2421   (let ((chosen (widget-radio-chosen widget)))
2422     (and chosen (widget-value chosen))))
2423
2424 (defun widget-radio-chosen (widget)
2425   "Return the widget representing the chosen radio button."
2426   (let ((children (widget-get widget :children))
2427         current found)
2428     (while children
2429       (setq current (car children)
2430             children (cdr children))
2431       (when (widget-apply (widget-get current :button) :value-get)
2432         (setq found current
2433               children nil)))
2434     found))
2435
2436 (defun widget-radio-value-inline (widget)
2437   ;; Get value of the child widget.
2438   (let ((children (widget-get widget :children))
2439         current found)
2440     (while children
2441       (setq current (car children)
2442             children (cdr children))
2443       (when (widget-apply (widget-get current :button) :value-get)
2444         (setq found (widget-apply current :value-inline)
2445               children nil)))
2446     found))
2447
2448 (defun widget-radio-value-set (widget value)
2449   ;; We can't just delete and recreate a radio widget, since children
2450   ;; can be added after the original creation and won't be recreated
2451   ;; by `:create'.
2452   (let ((children (widget-get widget :children))
2453         current found)
2454     (while children
2455       (setq current (car children)
2456             children (cdr children))
2457       (let* ((button (widget-get current :button))
2458              (match (and (not found)
2459                          (widget-apply current :match value))))
2460         (widget-value-set button match)
2461         (if match
2462             (progn
2463               (widget-value-set current value)
2464               (widget-apply current :activate))
2465           (widget-apply current :deactivate))
2466         (setq found (or found match))))))
2467
2468 (defun widget-radio-validate (widget)
2469   ;; Valid if we have made a valid choice.
2470   (let ((children (widget-get widget :children))
2471         current found button)
2472     (while (and children (not found))
2473       (setq current (car children)
2474             children (cdr children)
2475             button (widget-get current :button)
2476             found (widget-apply button :value-get)))
2477     (if found
2478         (widget-apply current :validate)
2479       widget)))
2480
2481 (defun widget-radio-action (widget child event)
2482   ;; Check if a radio button was pressed.
2483   (let ((children (widget-get widget :children))
2484         (buttons (widget-get widget :buttons))
2485         current)
2486     (when (memq child buttons)
2487       (while children
2488         (setq current (car children)
2489               children (cdr children))
2490         (let* ((button (widget-get current :button)))
2491           (cond ((eq child button)
2492                  (widget-value-set button t)
2493                  (widget-apply current :activate))
2494                 ((widget-value button)
2495                  (widget-value-set button nil)
2496                  (widget-apply current :deactivate)))))))
2497   ;; Pass notification to parent.
2498   (widget-apply widget :notify child event))
2499
2500 ;;; The `insert-button' Widget.
2501
2502 (define-widget 'insert-button 'push-button
2503   "An insert button for the `editable-list' widget."
2504   :tag "INS"
2505   :help-echo "Insert a new item into the list at this position."
2506   :action 'widget-insert-button-action)
2507
2508 (defun widget-insert-button-action (widget &optional event)
2509   ;; Ask the parent to insert a new item.
2510   (widget-apply (widget-get widget :parent)
2511                 :insert-before (widget-get widget :widget)))
2512
2513 ;;; The `delete-button' Widget.
2514
2515 (define-widget 'delete-button 'push-button
2516   "A delete button for the `editable-list' widget."
2517   :tag "DEL"
2518   :help-echo "Delete this item from the list."
2519   :action 'widget-delete-button-action)
2520
2521 (defun widget-delete-button-action (widget &optional event)
2522   ;; Ask the parent to insert a new item.
2523   (widget-apply (widget-get widget :parent)
2524                 :delete-at (widget-get widget :widget)))
2525
2526 ;;; The `editable-list' Widget.
2527
2528 ;; (defcustom widget-editable-list-gui nil
2529 ;;   "If non nil, use GUI push-buttons in editable list when available."
2530 ;;   :type 'boolean
2531 ;;   :group 'widgets)
2532
2533 (define-widget 'editable-list 'default
2534   "A variable list of widgets of the same type."
2535   :convert-widget 'widget-types-convert-widget
2536   :copy 'widget-types-copy
2537   :offset 12
2538   :format "%v%i\n"
2539   :format-handler 'widget-editable-list-format-handler
2540   :entry-format "%i %d %v"
2541   :value-create 'widget-editable-list-value-create
2542   :value-get 'widget-editable-list-value-get
2543   :validate 'widget-children-validate
2544   :match 'widget-editable-list-match
2545   :match-inline 'widget-editable-list-match-inline
2546   :insert-before 'widget-editable-list-insert-before
2547   :delete-at 'widget-editable-list-delete-at)
2548
2549 (defun widget-editable-list-format-handler (widget escape)
2550   ;; We recognize the insert button.
2551     ;; (let ((widget-push-button-gui widget-editable-list-gui))
2552     (cond ((eq escape ?i)
2553            (and (widget-get widget :indent)
2554                 (insert-char ?\s (widget-get widget :indent)))
2555            (apply 'widget-create-child-and-convert
2556                   widget 'insert-button
2557                   (widget-get widget :append-button-args)))
2558           (t
2559            (widget-default-format-handler widget escape)))
2560     ;; )
2561   )
2562
2563 (defun widget-editable-list-value-create (widget)
2564   ;; Insert all values
2565   (let* ((value (widget-get widget :value))
2566          (type (nth 0 (widget-get widget :args)))
2567          children)
2568     (widget-put widget :value-pos (copy-marker (point)))
2569     (set-marker-insertion-type (widget-get widget :value-pos) t)
2570     (while value
2571       (let ((answer (widget-match-inline type value)))
2572         (if answer
2573             (setq children (cons (widget-editable-list-entry-create
2574                                   widget
2575                                   (if (widget-get type :inline)
2576                                       (car answer)
2577                                     (car (car answer)))
2578                                   t)
2579                                  children)
2580                   value (cdr answer))
2581           (setq value nil))))
2582     (widget-put widget :children (nreverse children))))
2583
2584 (defun widget-editable-list-value-get (widget)
2585   ;; Get value of the child widget.
2586   (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
2587                          (widget-get widget :children))))
2588
2589 (defun widget-editable-list-match (widget value)
2590   ;; Value must be a list and all the members must match the type.
2591   (and (listp value)
2592        (null (cdr (widget-editable-list-match-inline widget value)))))
2593
2594 (defun widget-editable-list-match-inline (widget value)
2595   (let ((type (nth 0 (widget-get widget :args)))
2596         (ok t)
2597         found)
2598     (while (and value ok)
2599       (let ((answer (widget-match-inline type value)))
2600         (if answer
2601             (setq found (append found (car answer))
2602                   value (cdr answer))
2603           (setq ok nil))))
2604     (cons found value)))
2605
2606 (defun widget-editable-list-insert-before (widget before)
2607   ;; Insert a new child in the list of children.
2608   (save-excursion
2609     (let ((children (widget-get widget :children))
2610           (inhibit-read-only t)
2611           before-change-functions
2612           after-change-functions)
2613       (cond (before
2614              (goto-char (widget-get before :entry-from)))
2615             (t
2616              (goto-char (widget-get widget :value-pos))))
2617       (let ((child (widget-editable-list-entry-create
2618                     widget nil nil)))
2619         (when (< (widget-get child :entry-from) (widget-get widget :from))
2620           (set-marker (widget-get widget :from)
2621                       (widget-get child :entry-from)))
2622         (if (eq (car children) before)
2623             (widget-put widget :children (cons child children))
2624           (while (not (eq (car (cdr children)) before))
2625             (setq children (cdr children)))
2626           (setcdr children (cons child (cdr children)))))))
2627   (widget-setup)
2628   (widget-apply widget :notify widget))
2629
2630 (defun widget-editable-list-delete-at (widget child)
2631   ;; Delete child from list of children.
2632   (save-excursion
2633     (let ((buttons (copy-sequence (widget-get widget :buttons)))
2634           button
2635           (inhibit-read-only t)
2636           before-change-functions
2637           after-change-functions)
2638       (while buttons
2639         (setq button (car buttons)
2640               buttons (cdr buttons))
2641         (when (eq (widget-get button :widget) child)
2642           (widget-put widget
2643                       :buttons (delq button (widget-get widget :buttons)))
2644           (widget-delete button))))
2645     (let ((entry-from (widget-get child :entry-from))
2646           (entry-to (widget-get child :entry-to))
2647           (inhibit-read-only t)
2648           before-change-functions
2649           after-change-functions)
2650       (widget-delete child)
2651       (delete-region entry-from entry-to)
2652       (set-marker entry-from nil)
2653       (set-marker entry-to nil))
2654     (widget-put widget :children (delq child (widget-get widget :children))))
2655   (widget-setup)
2656   (widget-apply widget :notify widget))
2657
2658 (defun widget-editable-list-entry-create (widget value conv)
2659   ;; Create a new entry to the list.
2660   (let ((type (nth 0 (widget-get widget :args)))
2661         ;; (widget-push-button-gui widget-editable-list-gui)
2662         child delete insert)
2663     (widget-specify-insert
2664      (save-excursion
2665        (and (widget-get widget :indent)
2666             (insert-char ?\s (widget-get widget :indent)))
2667        (insert (widget-get widget :entry-format)))
2668      ;; Parse % escapes in format.
2669      (while (re-search-forward "%\\(.\\)" nil t)
2670        (let ((escape (char-after (match-beginning 1))))
2671          (delete-backward-char 2)
2672          (cond ((eq escape ?%)
2673                 (insert ?%))
2674                ((eq escape ?i)
2675                 (setq insert (apply 'widget-create-child-and-convert
2676                                     widget 'insert-button
2677                                     (widget-get widget :insert-button-args))))
2678                ((eq escape ?d)
2679                 (setq delete (apply 'widget-create-child-and-convert
2680                                     widget 'delete-button
2681                                     (widget-get widget :delete-button-args))))
2682                ((eq escape ?v)
2683                 (if conv
2684                     (setq child (widget-create-child-value
2685                                  widget type value))
2686                   (setq child (widget-create-child-value
2687                                widget type (widget-default-get type)))))
2688                (t
2689                 (error "Unknown escape `%c'" escape)))))
2690      (let ((buttons (widget-get widget :buttons)))
2691        (if insert (push insert buttons))
2692        (if delete (push delete buttons))
2693        (widget-put widget :buttons buttons))
2694      (let ((entry-from (point-min-marker))
2695            (entry-to (point-max-marker)))
2696        (set-marker-insertion-type entry-from t)
2697        (set-marker-insertion-type entry-to nil)
2698        (widget-put child :entry-from entry-from)
2699        (widget-put child :entry-to entry-to)))
2700     (if insert (widget-put insert :widget child))
2701     (if delete (widget-put delete :widget child))
2702     child))
2703
2704 ;;; The `group' Widget.
2705
2706 (define-widget 'group 'default
2707   "A widget which groups other widgets inside."
2708   :convert-widget 'widget-types-convert-widget
2709   :copy 'widget-types-copy
2710   :format "%v"
2711   :value-create 'widget-group-value-create
2712   :value-get 'widget-editable-list-value-get
2713   :default-get 'widget-group-default-get
2714   :validate 'widget-children-validate
2715   :match 'widget-group-match
2716   :match-inline 'widget-group-match-inline)
2717
2718 (defun widget-group-value-create (widget)
2719   ;; Create each component.
2720   (let ((args (widget-get widget :args))
2721         (value (widget-get widget :value))
2722         arg answer children)
2723     (while args
2724       (setq arg (car args)
2725             args (cdr args)
2726             answer (widget-match-inline arg value)
2727             value (cdr answer))
2728       (and (eq (preceding-char) ?\n)
2729            (widget-get widget :indent)
2730            (insert-char ?\s (widget-get widget :indent)))
2731       (push (cond ((null answer)
2732                    (widget-create-child widget arg))
2733                   ((widget-get arg :inline)
2734                    (widget-create-child-value widget arg (car answer)))
2735                   (t
2736                    (widget-create-child-value widget arg (car (car answer)))))
2737             children))
2738     (widget-put widget :children (nreverse children))))
2739
2740 (defun widget-group-default-get (widget)
2741   ;; Get the default of the components.
2742   (mapcar 'widget-default-get (widget-get widget :args)))
2743
2744 (defun widget-group-match (widget values)
2745   ;; Match if the components match.
2746   (and (listp values)
2747        (let ((match (widget-group-match-inline widget values)))
2748          (and match (null (cdr match))))))
2749
2750 (defun widget-group-match-inline (widget vals)
2751   ;; Match if the components match.
2752   (let ((args (widget-get widget :args))
2753         argument answer found)
2754     (while args
2755       (setq argument (car args)
2756             args (cdr args)
2757             answer (widget-match-inline argument vals))
2758       (if answer
2759           (setq vals (cdr answer)
2760                 found (append found (car answer)))
2761         (setq vals nil
2762               args nil)))
2763     (if answer
2764         (cons found vals))))
2765
2766 ;;; The `visibility' Widget.
2767
2768 (define-widget 'visibility 'item
2769   "An indicator and manipulator for hidden items."
2770   :format "%[%v%]"
2771   :button-prefix ""
2772   :button-suffix ""
2773   :on "Hide"
2774   :off "Show"
2775   :value-create 'widget-visibility-value-create
2776   :action 'widget-toggle-action
2777   :match (lambda (widget value) t))
2778
2779 (defun widget-visibility-value-create (widget)
2780   ;; Insert text representing the `on' and `off' states.
2781   (let ((on (widget-get widget :on))
2782         (off (widget-get widget :off)))
2783     (if on
2784         (setq on (concat widget-push-button-prefix
2785                          on
2786                          widget-push-button-suffix))
2787       (setq on ""))
2788     (if off
2789         (setq off (concat widget-push-button-prefix
2790                           off
2791                           widget-push-button-suffix))
2792       (setq off ""))
2793     (if (widget-value widget)
2794         (widget-image-insert widget on "down" "down-pushed")
2795       (widget-image-insert widget off "right" "right-pushed"))))
2796
2797 ;;; The `documentation-link' Widget.
2798 ;;
2799 ;; This is a helper widget for `documentation-string'.
2800
2801 (define-widget 'documentation-link 'link
2802   "Link type used in documentation strings."
2803   :tab-order -1
2804   :help-echo "Describe this symbol"
2805   :action 'widget-documentation-link-action)
2806
2807 (defun widget-documentation-link-action (widget &optional event)
2808   "Display documentation for WIDGET's value.  Ignore optional argument EVENT."
2809   (let* ((string (widget-get widget :value))
2810          (symbol (intern string)))
2811     (if (and (fboundp symbol) (boundp symbol))
2812         ;; If there are two doc strings, give the user a way to pick one.
2813         (apropos (concat "\\`" (regexp-quote string) "\\'"))
2814       (if (fboundp symbol)
2815           (describe-function symbol)
2816         (describe-variable symbol)))))
2817
2818 (defcustom widget-documentation-links t
2819   "Add hyperlinks to documentation strings when non-nil."
2820   :type 'boolean
2821   :group 'widget-documentation)
2822
2823 (defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'"
2824   "Regexp for matching potential links in documentation strings.
2825 The first group should be the link itself."
2826   :type 'regexp
2827   :group 'widget-documentation)
2828
2829 (defcustom widget-documentation-link-p 'intern-soft
2830   "Predicate used to test if a string is useful as a link.
2831 The value should be a function.  The function will be called one
2832 argument, a string, and should return non-nil if there should be a
2833 link for that string."
2834   :type 'function
2835   :options '(widget-documentation-link-p)
2836   :group 'widget-documentation)
2837
2838 (defcustom widget-documentation-link-type 'documentation-link
2839   "Widget type used for links in documentation strings."
2840   :type 'symbol
2841   :group 'widget-documentation)
2842
2843 (defun widget-documentation-link-add (widget from to)
2844   (widget-specify-doc widget from to)
2845   (when widget-documentation-links
2846     (let ((regexp widget-documentation-link-regexp)
2847           (buttons (widget-get widget :buttons))
2848           (widget-mouse-face (default-value 'widget-mouse-face))
2849           (widget-button-face widget-documentation-face)
2850           (widget-button-pressed-face widget-documentation-face))
2851       (save-excursion
2852         (goto-char from)
2853         (while (re-search-forward regexp to t)
2854           (let ((name (match-string 1))
2855                 (begin (match-beginning 1))
2856                 (end (match-end 1)))
2857             (when (funcall widget-documentation-link-p name)
2858               (push (widget-convert-button widget-documentation-link-type
2859                                            begin end :value name)
2860                     buttons)))))
2861       (widget-put widget :buttons buttons)))
2862   (let ((indent (widget-get widget :indent)))
2863     (when (and indent (not (zerop indent)))
2864       (save-excursion
2865         (save-restriction
2866           (narrow-to-region from to)
2867           (goto-char (point-min))
2868           (while (search-forward "\n" nil t)
2869             (insert-char ?\s indent)))))))
2870
2871 ;;; The `documentation-string' Widget.
2872
2873 (define-widget 'documentation-string 'item
2874   "A documentation string."
2875   :format "%v"
2876   :action 'widget-documentation-string-action
2877   :value-create 'widget-documentation-string-value-create)
2878
2879 (defun widget-documentation-string-value-create (widget)
2880   ;; Insert documentation string.
2881   (let ((doc (widget-value widget))
2882         (indent (widget-get widget :indent))
2883         (shown (widget-get (widget-get widget :parent) :documentation-shown))
2884         (start (point)))
2885     (if (string-match "\n" doc)
2886         (let ((before (substring doc 0 (match-beginning 0)))
2887               (after (substring doc (match-beginning 0)))
2888               button)
2889           (insert before ?\s)
2890           (widget-documentation-link-add widget start (point))
2891           (setq button
2892                 (widget-create-child-and-convert
2893                  widget 'visibility
2894                  :help-echo "Show or hide rest of the documentation."
2895                  :on "Hide Rest"
2896                  :off "More"
2897                  :always-active t
2898                  :action 'widget-parent-action
2899                  shown))
2900           (when shown
2901             (setq start (point))
2902             (when (and indent (not (zerop indent)))
2903               (insert-char ?\s indent))
2904             (insert after)
2905             (widget-documentation-link-add widget start (point)))
2906           (widget-put widget :buttons (list button)))
2907       (insert doc)
2908       (widget-documentation-link-add widget start (point))))
2909   (insert ?\n))
2910
2911 (defun widget-documentation-string-action (widget &rest ignore)
2912   ;; Toggle documentation.
2913   (let ((parent (widget-get widget :parent)))
2914     (widget-put parent :documentation-shown
2915                 (not (widget-get parent :documentation-shown))))
2916   ;; Redraw.
2917   (widget-value-set widget (widget-value widget)))
2918 \f
2919 ;;; The Sexp Widgets.
2920
2921 (define-widget 'const 'item
2922   "An immutable sexp."
2923   :prompt-value 'widget-const-prompt-value
2924   :format "%t\n%d")
2925
2926 (defun widget-const-prompt-value (widget prompt value unbound)
2927   ;; Return the value of the const.
2928   (widget-value widget))
2929
2930 (define-widget 'function-item 'const
2931   "An immutable function name."
2932   :format "%v\n%h"
2933   :documentation-property (lambda (symbol)
2934                             (condition-case nil
2935                                 (documentation symbol t)
2936                               (error nil))))
2937
2938 (define-widget 'variable-item 'const
2939   "An immutable variable name."
2940   :format "%v\n%h"
2941   :documentation-property 'variable-documentation)
2942
2943 (define-widget 'other 'sexp
2944   "Matches any value, but doesn't let the user edit the value.
2945 This is useful as last item in a `choice' widget.
2946 You should use this widget type with a default value,
2947 as in (other DEFAULT) or (other :tag \"NAME\" DEFAULT).
2948 If the user selects this alternative, that specifies DEFAULT
2949 as the value."
2950   :tag "Other"
2951   :format "%t%n"
2952   :value 'other)
2953
2954 (defvar widget-string-prompt-value-history nil
2955   "History of input to `widget-string-prompt-value'.")
2956
2957 (define-widget 'string 'editable-field
2958   "A string"
2959   :tag "String"
2960   :format "%{%t%}: %v"
2961   :complete-function 'ispell-complete-word
2962   :prompt-history 'widget-string-prompt-value-history)
2963
2964 (define-widget 'regexp 'string
2965   "A regular expression."
2966   :match 'widget-regexp-match
2967   :validate 'widget-regexp-validate
2968   ;; Doesn't work well with terminating newline.
2969   ;; :value-face 'widget-single-line-field
2970   :tag "Regexp")
2971
2972 (defun widget-regexp-match (widget value)
2973   ;; Match valid regexps.
2974   (and (stringp value)
2975        (condition-case nil
2976            (prog1 t
2977              (string-match value ""))
2978          (error nil))))
2979
2980 (defun widget-regexp-validate (widget)
2981   "Check that the value of WIDGET is a valid regexp."
2982   (condition-case data
2983       (prog1 nil
2984         (string-match (widget-value widget) ""))
2985     (error (widget-put widget :error (error-message-string data))
2986            widget)))
2987
2988 (define-widget 'file 'string
2989   "A file widget.
2990 It will read a file name from the minibuffer when invoked."
2991   :complete-function 'widget-file-complete
2992   :prompt-value 'widget-file-prompt-value
2993   :format "%{%t%}: %v"
2994   ;; Doesn't work well with terminating newline.
2995   ;; :value-face 'widget-single-line-field
2996   :tag "File")
2997
2998 (defun widget-file-complete ()
2999   "Perform completion on file name preceding point."
3000   (interactive)
3001   (let* ((end (point))
3002          (beg (widget-field-start widget))
3003          (pattern (buffer-substring beg end))
3004          (name-part (file-name-nondirectory pattern))
3005          ;; I think defaulting to root is right
3006          ;; because these really should be absolute file names.
3007          (directory (or (file-name-directory pattern) "/"))
3008          (completion (file-name-completion name-part directory)))
3009     (cond ((eq completion t))
3010           ((null completion)
3011            (message "Can't find completion for \"%s\"" pattern)
3012            (ding))
3013           ((not (string= name-part completion))
3014            (delete-region beg end)
3015            (insert (expand-file-name completion directory)))
3016           (t
3017            (message "Making completion list...")
3018            (with-output-to-temp-buffer "*Completions*"
3019              (display-completion-list
3020               (sort (file-name-all-completions name-part directory)
3021                     'string<)
3022               name-part))
3023            (message "Making completion list...%s" "done")))))
3024
3025 (defun widget-file-prompt-value (widget prompt value unbound)
3026   ;; Read file from minibuffer.
3027   (abbreviate-file-name
3028    (if unbound
3029        (read-file-name prompt)
3030      (let ((prompt2 (format "%s (default %s): " prompt value))
3031            (dir (file-name-directory value))
3032            (file (file-name-nondirectory value))
3033            (must-match (widget-get widget :must-match)))
3034        (read-file-name prompt2 dir nil must-match file)))))
3035
3036 ;;;(defun widget-file-action (widget &optional event)
3037 ;;;  ;; Read a file name from the minibuffer.
3038 ;;;  (let* ((value (widget-value widget))
3039 ;;;      (dir (file-name-directory value))
3040 ;;;      (file (file-name-nondirectory value))
3041 ;;;      (menu-tag (widget-apply widget :menu-tag-get))
3042 ;;;      (must-match (widget-get widget :must-match))
3043 ;;;      (answer (read-file-name (concat menu-tag " (default " value "): ")
3044 ;;;                              dir nil must-match file)))
3045 ;;;    (widget-value-set widget (abbreviate-file-name answer))
3046 ;;;    (widget-setup)
3047 ;;;    (widget-apply widget :notify widget event)))
3048
3049 ;; Fixme: use file-name-as-directory.
3050 (define-widget 'directory 'file
3051   "A directory widget.
3052 It will read a directory name from the minibuffer when invoked."
3053   :tag "Directory")
3054
3055 (defvar widget-symbol-prompt-value-history nil
3056   "History of input to `widget-symbol-prompt-value'.")
3057
3058 (define-widget 'symbol 'editable-field
3059   "A Lisp symbol."
3060   :value nil
3061   :tag "Symbol"
3062   :format "%{%t%}: %v"
3063   :match (lambda (widget value) (symbolp value))
3064   :complete-function 'lisp-complete-symbol
3065   :prompt-internal 'widget-symbol-prompt-internal
3066   :prompt-match 'symbolp
3067   :prompt-history 'widget-symbol-prompt-value-history
3068   :value-to-internal (lambda (widget value)
3069                        (if (symbolp value)
3070                            (symbol-name value)
3071                          value))
3072   :value-to-external (lambda (widget value)
3073                        (if (stringp value)
3074                            (intern value)
3075                          value)))
3076
3077 (defun widget-symbol-prompt-internal (widget prompt initial history)
3078   ;; Read file from minibuffer.
3079   (let ((answer (completing-read prompt obarray
3080                                  (widget-get widget :prompt-match)
3081                                  nil initial history)))
3082     (if (and (stringp answer)
3083              (not (zerop (length answer))))
3084         answer
3085       (error "No value"))))
3086
3087 (defvar widget-function-prompt-value-history nil
3088   "History of input to `widget-function-prompt-value'.")
3089
3090 (define-widget 'function 'restricted-sexp
3091   "A Lisp function."
3092   :complete-function (lambda ()
3093                        (interactive)
3094                        (lisp-complete-symbol 'fboundp))
3095   :prompt-value 'widget-field-prompt-value
3096   :prompt-internal 'widget-symbol-prompt-internal
3097   :prompt-match 'fboundp
3098   :prompt-history 'widget-function-prompt-value-history
3099   :action 'widget-field-action
3100   :match-alternatives '(functionp)
3101   :validate (lambda (widget)
3102               (unless (functionp (widget-value widget))
3103                 (widget-put widget :error (format "Invalid function: %S"
3104                                                   (widget-value widget)))
3105                 widget))
3106   :value 'ignore
3107   :tag "Function")
3108
3109 (defvar widget-variable-prompt-value-history nil
3110   "History of input to `widget-variable-prompt-value'.")
3111
3112 (define-widget 'variable 'symbol
3113   "A Lisp variable."
3114   :prompt-match 'boundp
3115   :prompt-history 'widget-variable-prompt-value-history
3116   :complete-function (lambda ()
3117                        (interactive)
3118                        (lisp-complete-symbol 'boundp))
3119   :tag "Variable")
3120 \f
3121 (defvar widget-coding-system-prompt-value-history nil
3122   "History of input to `widget-coding-system-prompt-value'.")
3123
3124 (define-widget 'coding-system 'symbol
3125   "A MULE coding-system."
3126   :format "%{%t%}: %v"
3127   :tag "Coding system"
3128   :base-only nil
3129   :prompt-history 'widget-coding-system-prompt-value-history
3130   :prompt-value 'widget-coding-system-prompt-value
3131   :action 'widget-coding-system-action
3132   :complete-function (lambda ()
3133                        (interactive)
3134                        (lisp-complete-symbol 'coding-system-p))
3135   :validate (lambda (widget)
3136               (unless (coding-system-p (widget-value widget))
3137                 (widget-put widget :error (format "Invalid coding system: %S"
3138                                                   (widget-value widget)))
3139                 widget))
3140   :value 'undecided
3141   :prompt-match 'coding-system-p)
3142
3143 (defun widget-coding-system-prompt-value (widget prompt value unbound)
3144   "Read coding-system from minibuffer."
3145   (if (widget-get widget :base-only)
3146       (intern
3147        (completing-read (format "%s (default %s): " prompt value)
3148                         (mapcar #'list (coding-system-list t)) nil nil nil
3149                         coding-system-history))
3150       (read-coding-system (format "%s (default %s): " prompt value) value)))
3151
3152 (defun widget-coding-system-action (widget &optional event)
3153   (let ((answer
3154          (widget-coding-system-prompt-value
3155           widget
3156           (widget-apply widget :menu-tag-get)
3157           (widget-value widget)
3158           t)))
3159     (widget-value-set widget answer)
3160     (widget-apply widget :notify widget event)
3161     (widget-setup)))
3162 \f
3163 (defvar widget-key-sequence-prompt-value-history nil
3164   "History of input to `widget-key-sequence-prompt-value'.")
3165
3166 ;; This mostly works, but I am pretty sure it needs more change
3167 ;; to be 100% correct.  I don't know what the change should be -- rms.
3168
3169 (define-widget 'key-sequence 'restricted-sexp
3170   "A Lisp function."
3171   :prompt-value 'widget-field-prompt-value
3172   :prompt-internal 'widget-symbol-prompt-internal
3173   :prompt-match 'fboundp
3174   :prompt-history 'widget-key-sequence-prompt-value-history
3175   :action 'widget-field-action
3176   :match-alternatives '(stringp vectorp)
3177   :validate (lambda (widget)
3178               (unless (or (stringp (widget-value widget))
3179                           (vectorp (widget-value widget)))
3180                 (widget-put widget :error (format "Invalid key sequence: %S"
3181                                                   (widget-value widget)))
3182                 widget))
3183   :value 'ignore
3184   :tag "Key sequence")
3185 \f
3186 (define-widget 'sexp 'editable-field
3187   "An arbitrary Lisp expression."
3188   :tag "Lisp expression"
3189   :format "%{%t%}: %v"
3190   :value nil
3191   :validate 'widget-sexp-validate
3192   :match (lambda (widget value) t)
3193   :value-to-internal 'widget-sexp-value-to-internal
3194   :value-to-external (lambda (widget value) (read value))
3195   :prompt-history 'widget-sexp-prompt-value-history
3196   :prompt-value 'widget-sexp-prompt-value)
3197
3198 (defun widget-sexp-value-to-internal (widget value)
3199   ;; Use pp for printer representation.
3200   (let ((pp (if (symbolp value)
3201                 (prin1-to-string value)
3202               (pp-to-string value))))
3203     (while (string-match "\n\\'" pp)
3204       (setq pp (substring pp 0 -1)))
3205     (if (or (string-match "\n\\'" pp)
3206             (> (length pp) 40))
3207         (concat "\n" pp)
3208       pp)))
3209
3210 (defun widget-sexp-validate (widget)
3211   ;; Valid if we can read the string and there is no junk left after it.
3212   (with-temp-buffer
3213     (insert (widget-apply widget :value-get))
3214     (goto-char (point-min))
3215     (let (err)
3216       (condition-case data
3217           (progn
3218             ;; Avoid a confusing end-of-file error.
3219             (skip-syntax-forward "\\s-")
3220             (if (eobp)
3221                 (setq err "Empty sexp -- use `nil'?")
3222               (unless (widget-apply widget :match (read (current-buffer)))
3223                 (setq err (widget-get widget :type-error))))
3224             ;; Allow whitespace after expression.
3225             (skip-syntax-forward "\\s-")
3226             (if (and (not (eobp))
3227                      (not err))
3228                 (setq err (format "Junk at end of expression: %s"
3229                                   (buffer-substring (point)
3230                                                     (point-max))))))
3231         (end-of-file                    ; Avoid confusing error message.
3232          (setq err "Unbalanced sexp"))
3233         (error (setq err (error-message-string data))))
3234       (if (not err)
3235           nil
3236         (widget-put widget :error err)
3237         widget))))
3238
3239 (defvar widget-sexp-prompt-value-history nil
3240   "History of input to `widget-sexp-prompt-value'.")
3241
3242 (defun widget-sexp-prompt-value (widget prompt value unbound)
3243   ;; Read an arbitrary sexp.
3244   (let ((found (read-string prompt
3245                             (if unbound nil (cons (prin1-to-string value) 0))
3246                             (widget-get widget :prompt-history))))
3247     (let ((answer (read-from-string found)))
3248       (unless (= (cdr answer) (length found))
3249         (error "Junk at end of expression: %s"
3250                (substring found (cdr answer))))
3251       (car answer))))
3252
3253 (define-widget 'restricted-sexp 'sexp
3254   "A Lisp expression restricted to values that match.
3255 To use this type, you must define :match or :match-alternatives."
3256   :type-error "The specified value is not valid"
3257   :match 'widget-restricted-sexp-match
3258   :value-to-internal (lambda (widget value)
3259                        (if (widget-apply widget :match value)
3260                            (prin1-to-string value)
3261                          value)))
3262
3263 (defun widget-restricted-sexp-match (widget value)
3264   (let ((alternatives (widget-get widget :match-alternatives))
3265         matched)
3266     (while (and alternatives (not matched))
3267       (if (cond ((functionp (car alternatives))
3268                  (funcall (car alternatives) value))
3269                 ((and (consp (car alternatives))
3270                       (eq (car (car alternatives)) 'quote))
3271                  (eq value (nth 1 (car alternatives)))))
3272           (setq matched t))
3273       (setq alternatives (cdr alternatives)))
3274     matched))
3275 \f
3276 (define-widget 'integer 'restricted-sexp
3277   "An integer."
3278   :tag "Integer"
3279   :value 0
3280   :type-error "This field should contain an integer"
3281   :match-alternatives '(integerp))
3282
3283 (define-widget 'number 'restricted-sexp
3284   "A number (floating point or integer)."
3285   :tag "Number"
3286   :value 0.0
3287   :type-error "This field should contain a number (floating point or integer)"
3288   :match-alternatives '(numberp))
3289
3290 (define-widget 'float 'restricted-sexp
3291   "A floating point number."
3292   :tag "Floating point number"
3293   :value 0.0
3294   :type-error "This field should contain a floating point number"
3295   :match-alternatives '(floatp))
3296
3297 (define-widget 'character 'editable-field
3298   "A character."
3299   :tag "Character"
3300   :value 0
3301   :size 1
3302   :format "%{%t%}: %v\n"
3303   :valid-regexp "\\`.\\'"
3304   :error "This field should contain a single character"
3305   :value-to-internal (lambda (widget value)
3306                        (if (stringp value)
3307                            value
3308                          (char-to-string value)))
3309   :value-to-external (lambda (widget value)
3310                        (if (stringp value)
3311                            (aref value 0)
3312                          value))
3313   :match (lambda (widget value)
3314            (char-valid-p value)))
3315
3316 (define-widget 'list 'group
3317   "A Lisp list."
3318   :tag "List"
3319   :format "%{%t%}:\n%v")
3320
3321 (define-widget 'vector 'group
3322   "A Lisp vector."
3323   :tag "Vector"
3324   :format "%{%t%}:\n%v"
3325   :match 'widget-vector-match
3326   :value-to-internal (lambda (widget value) (append value nil))
3327   :value-to-external (lambda (widget value) (apply 'vector value)))
3328
3329 (defun widget-vector-match (widget value)
3330   (and (vectorp value)
3331        (widget-group-match widget
3332                            (widget-apply widget :value-to-internal value))))
3333
3334 (define-widget 'cons 'group
3335   "A cons-cell."
3336   :tag "Cons-cell"
3337   :format "%{%t%}:\n%v"
3338   :match 'widget-cons-match
3339   :value-to-internal (lambda (widget value)
3340                        (list (car value) (cdr value)))
3341   :value-to-external (lambda (widget value)
3342                        (apply 'cons value)))
3343
3344 (defun widget-cons-match (widget value)
3345   (and (consp value)
3346        (widget-group-match widget
3347                            (widget-apply widget :value-to-internal value))))
3348 \f
3349 ;;; The `lazy' Widget.
3350 ;;
3351 ;; Recursive datatypes.
3352
3353 (define-widget 'lazy 'default
3354   "Base widget for recursive datastructures.
3355
3356 The `lazy' widget will, when instantiated, contain a single inferior
3357 widget, of the widget type specified by the :type parameter.  The
3358 value of the `lazy' widget is the same as the value of the inferior
3359 widget.  When deriving a new widget from the 'lazy' widget, the :type
3360 parameter is allowed to refer to the widget currently being defined,
3361 thus allowing recursive datastructures to be described.
3362
3363 The :type parameter takes the same arguments as the defcustom
3364 parameter with the same name.
3365
3366 Most composite widgets, i.e. widgets containing other widgets, does
3367 not allow recursion.  That is, when you define a new widget type, none
3368 of the inferior widgets may be of the same type you are currently
3369 defining.
3370
3371 In Lisp, however, it is custom to define datastructures in terms of
3372 themselves.  A list, for example, is defined as either nil, or a cons
3373 cell whose cdr itself is a list.  The obvious way to translate this
3374 into a widget type would be
3375
3376   (define-widget 'my-list 'choice
3377     \"A list of sexps.\"
3378     :tag \"Sexp list\"
3379     :args '((const nil) (cons :value (nil) sexp my-list)))
3380
3381 Here we attempt to define my-list as a choice of either the constant
3382 nil, or a cons-cell containing a sexp and my-lisp.  This will not work
3383 because the `choice' widget does not allow recursion.
3384
3385 Using the `lazy' widget you can overcome this problem, as in this
3386 example:
3387
3388   (define-widget 'sexp-list 'lazy
3389     \"A list of sexps.\"
3390     :tag \"Sexp list\"
3391     :type '(choice (const nil) (cons :value (nil) sexp sexp-list)))"
3392   :format "%{%t%}: %v"
3393   ;; We don't convert :type because we want to allow recursive
3394   ;; datastructures.  This is slow, so we should not create speed
3395   ;; critical widgets by deriving from this.
3396   :convert-widget 'widget-value-convert-widget
3397   :value-create 'widget-type-value-create
3398   :value-get 'widget-child-value-get
3399   :value-inline 'widget-child-value-inline
3400   :default-get 'widget-type-default-get
3401   :match 'widget-type-match
3402   :validate 'widget-child-validate)
3403
3404 \f
3405 ;;; The `plist' Widget.
3406 ;;
3407 ;; Property lists.
3408
3409 (define-widget 'plist 'list
3410   "A property list."
3411   :key-type '(symbol :tag "Key")
3412   :value-type '(sexp :tag "Value")
3413   :convert-widget 'widget-plist-convert-widget
3414   :tag "Plist")
3415
3416 (defvar widget-plist-value-type)        ;Dynamic variable
3417
3418 (defun widget-plist-convert-widget (widget)
3419   ;; Handle `:options'.
3420   (let* ((options (widget-get widget :options))
3421          (widget-plist-value-type (widget-get widget :value-type))
3422          (other `(editable-list :inline t
3423                                 (group :inline t
3424                                        ,(widget-get widget :key-type)
3425                                        ,widget-plist-value-type)))
3426          (args (if options
3427                    (list `(checklist :inline t
3428                                      :greedy t
3429                                      ,@(mapcar 'widget-plist-convert-option
3430                                                options))
3431                          other)
3432                  (list other))))
3433     (widget-put widget :args args)
3434     widget))
3435
3436 (defun widget-plist-convert-option (option)
3437   ;; Convert a single plist option.
3438   (let (key-type value-type)
3439     (if (listp option)
3440         (let ((key (nth 0 option)))
3441           (setq value-type (nth 1 option))
3442           (if (listp key)
3443               (setq key-type key)
3444             (setq key-type `(const ,key))))
3445       (setq key-type `(const ,option)
3446             value-type widget-plist-value-type))
3447     `(group :format "Key: %v" :inline t ,key-type ,value-type)))
3448
3449
3450 ;;; The `alist' Widget.
3451 ;;
3452 ;; Association lists.
3453
3454 (define-widget 'alist 'list
3455   "An association list."
3456   :key-type '(sexp :tag "Key")
3457   :value-type '(sexp :tag "Value")
3458   :convert-widget 'widget-alist-convert-widget
3459   :tag "Alist")
3460
3461 (defvar widget-alist-value-type)        ;Dynamic variable
3462
3463 (defun widget-alist-convert-widget (widget)
3464   ;; Handle `:options'.
3465   (let* ((options (widget-get widget :options))
3466          (widget-alist-value-type (widget-get widget :value-type))
3467          (other `(editable-list :inline t
3468                                 (cons :format "%v"
3469                                       ,(widget-get widget :key-type)
3470                                       ,widget-alist-value-type)))
3471          (args (if options
3472                    (list `(checklist :inline t
3473                                      :greedy t
3474                                      ,@(mapcar 'widget-alist-convert-option
3475                                                options))
3476                          other)
3477                  (list other))))
3478     (widget-put widget :args args)
3479     widget))
3480
3481 (defun widget-alist-convert-option (option)
3482   ;; Convert a single alist option.
3483   (let (key-type value-type)
3484     (if (listp option)
3485         (let ((key (nth 0 option)))
3486           (setq value-type (nth 1 option))
3487           (if (listp key)
3488               (setq key-type key)
3489             (setq key-type `(const ,key))))
3490       (setq key-type `(const ,option)
3491             value-type widget-alist-value-type))
3492     `(cons :format "Key: %v" ,key-type ,value-type)))
3493 \f
3494 (define-widget 'choice 'menu-choice
3495   "A union of several sexp types."
3496   :tag "Choice"
3497   :format "%{%t%}: %[Value Menu%] %v"
3498   :button-prefix 'widget-push-button-prefix
3499   :button-suffix 'widget-push-button-suffix
3500   :prompt-value 'widget-choice-prompt-value)
3501
3502 (defun widget-choice-prompt-value (widget prompt value unbound)
3503   "Make a choice."
3504   (let ((args (widget-get widget :args))
3505         (completion-ignore-case (widget-get widget :case-fold))
3506         current choices old)
3507     ;; Find the first arg that matches VALUE.
3508     (let ((look args))
3509       (while look
3510         (if (widget-apply (car look) :match value)
3511             (setq old (car look)
3512                   look nil)
3513           (setq look (cdr look)))))
3514     ;; Find new choice.
3515     (setq current
3516           (cond ((= (length args) 0)
3517                  nil)
3518                 ((= (length args) 1)
3519                  (nth 0 args))
3520                 ((and (= (length args) 2)
3521                       (memq old args))
3522                  (if (eq old (nth 0 args))
3523                      (nth 1 args)
3524                    (nth 0 args)))
3525                 (t
3526                  (while args
3527                    (setq current (car args)
3528                          args (cdr args))
3529                    (setq choices
3530                          (cons (cons (widget-apply current :menu-tag-get)
3531                                      current)
3532                                choices)))
3533                  (let ((val (completing-read prompt choices nil t)))
3534                    (if (stringp val)
3535                        (let ((try (try-completion val choices)))
3536                          (when (stringp try)
3537                            (setq val try))
3538                          (cdr (assoc val choices)))
3539                      nil)))))
3540     (if current
3541         (widget-prompt-value current prompt nil t)
3542       value)))
3543 \f
3544 (define-widget 'radio 'radio-button-choice
3545   "A union of several sexp types."
3546   :tag "Choice"
3547   :format "%{%t%}:\n%v"
3548   :prompt-value 'widget-choice-prompt-value)
3549
3550 (define-widget 'repeat 'editable-list
3551   "A variable length homogeneous list."
3552   :tag "Repeat"
3553   :format "%{%t%}:\n%v%i\n")
3554
3555 (define-widget 'set 'checklist
3556   "A list of members from a fixed set."
3557   :tag "Set"
3558   :format "%{%t%}:\n%v")
3559
3560 (define-widget 'boolean 'toggle
3561   "To be nil or non-nil, that is the question."
3562   :tag "Boolean"
3563   :prompt-value 'widget-boolean-prompt-value
3564   :button-prefix 'widget-push-button-prefix
3565   :button-suffix 'widget-push-button-suffix
3566   :format "%{%t%}: %[Toggle%]  %v\n"
3567   :on "on (non-nil)"
3568   :off "off (nil)")
3569
3570 (defun widget-boolean-prompt-value (widget prompt value unbound)
3571   ;; Toggle a boolean.
3572   (y-or-n-p prompt))
3573 \f
3574 ;;; The `color' Widget.
3575
3576 ;; Fixme: match
3577 (define-widget 'color 'editable-field
3578   "Choose a color name (with sample)."
3579   :format "%{%t%}: %v (%{sample%})\n"
3580   :size 10
3581   :tag "Color"
3582   :value "black"
3583   :complete 'widget-color-complete
3584   :sample-face-get 'widget-color-sample-face-get
3585   :notify 'widget-color-notify
3586   :action 'widget-color-action)
3587
3588 (defun widget-color-complete (widget)
3589   "Complete the color in WIDGET."
3590   (require 'facemenu)                   ; for facemenu-color-alist
3591   (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
3592                                                  (point)))
3593          (list (or facemenu-color-alist (defined-colors)))
3594          (completion (try-completion prefix list)))
3595     (cond ((eq completion t)
3596            (message "Exact match."))
3597           ((null completion)
3598            (error "Can't find completion for \"%s\"" prefix))
3599           ((not (string-equal prefix completion))
3600            (insert-and-inherit (substring completion (length prefix))))
3601           (t
3602            (message "Making completion list...")
3603            (with-output-to-temp-buffer "*Completions*"
3604              (display-completion-list (all-completions prefix list nil)
3605                                       prefix))
3606            (message "Making completion list...done")))))
3607
3608 (defun widget-color-sample-face-get (widget)
3609   (let* ((value (condition-case nil
3610                     (widget-value widget)
3611                   (error (widget-get widget :value)))))
3612     (if (color-defined-p value)
3613         (list (cons 'foreground-color value))
3614       'default)))
3615
3616 (defun widget-color-action (widget &optional event)
3617   "Prompt for a color."
3618   (let* ((tag (widget-apply widget :menu-tag-get))
3619          (prompt (concat tag ": "))
3620          (value (widget-value widget))
3621          (start (widget-field-start widget))
3622          (answer (facemenu-read-color prompt)))
3623     (unless (zerop (length answer))
3624       (widget-value-set widget answer)
3625       (widget-setup)
3626       (widget-apply widget :notify widget event))))
3627
3628 (defun widget-color-notify (widget child &optional event)
3629   "Update the sample, and notify the parent."
3630   (overlay-put (widget-get widget :sample-overlay)
3631                'face (widget-apply widget :sample-face-get))
3632   (widget-default-notify widget child event))
3633 \f
3634 ;;; The Help Echo
3635
3636 (defun widget-echo-help (pos)
3637   "Display help-echo text for widget at POS."
3638   (let* ((widget (widget-at pos))
3639          (help-echo (and widget (widget-get widget :help-echo))))
3640     (if (functionp help-echo)
3641         (setq help-echo (funcall help-echo widget)))
3642     (if help-echo (message "%s" (eval help-echo)))))
3643
3644 ;;; The End:
3645
3646 (provide 'wid-edit)
3647
3648 ;;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707
3649 ;;; wid-edit.el ends here