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