cgit.sxemacs.org Git - gnus/blob - lisp/wid-edit.el

   1 ;;; wid-edit.el --- Functions for creating and using widgets.
   2 ;;
   3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: extensions
   7 ;; Version: 1.65
   8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
   9
  10 ;;; Commentary:
  11 ;;
  12 ;; See `widget.el'.
  13
  14 ;;; Code:
  15
  16 (require 'widget)
  17
  18 (eval-and-compile
  19   (require 'cl))
  20
  21 ;;; Compatibility.
  22
  23 (eval-and-compile
  24   (autoload 'pp-to-string "pp")
  25   (autoload 'Info-goto-node "info")
  26
  27   (if (string-match "XEmacs" emacs-version)
  28       ;; XEmacs spell `intangible' as `atomic'.
  29       (defun widget-make-intangible (from to side)
  30         "Make text between FROM and TO atomic with regard to movement.
  31 Third argument should be `start-open' if it should be sticky to the rear,
  32 and `end-open' if it should sticky to the front."
  33         (require 'atomic-extents)
  34         (let ((ext (make-extent from to)))
  35            ;; XEmacs doesn't understant different kinds of read-only, so
  36            ;; we have to use extents instead.
  37           (put-text-property from to 'read-only nil)
  38           (set-extent-property ext 'read-only t)
  39           (set-extent-property ext 'start-open nil)
  40           (set-extent-property ext 'end-open nil)
  41           (set-extent-property ext side t)
  42           (set-extent-property ext 'atomic t)))
  43     (defun widget-make-intangible (from to size)
  44       "Make text between FROM and TO intangible."
  45       (put-text-property from to 'intangible 'front)))
  46
  47 ;; The following should go away when bundled with Emacs.
  48   (condition-case ()
  49       (require 'custom)
  50     (error nil))
  51
  52   (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
  53     ;; We have the old custom-library, hack around it!
  54     (defmacro defgroup (&rest args) nil)
  55     (defmacro defcustom (var value doc &rest args)
  56       `(defvar ,var ,value ,doc))
  57     (defmacro defface (&rest args) nil)
  58     (define-widget-keywords :prefix :tag :load :link :options :type :group)
  59     (when (fboundp 'copy-face)
  60       (copy-face 'default 'widget-documentation-face)
  61       (copy-face 'bold 'widget-button-face)
  62       (copy-face 'italic 'widget-field-face)))
  63
  64   (unless (fboundp 'event-point)
  65     ;; XEmacs function missing in Emacs.
  66     (defun event-point (event)
  67       "Return the character position of the given mouse-motion, button-press,
  68 or button-release event.  If the event did not occur over a window, or did
  69 not occur over text, then this returns nil.  Otherwise, it returns an index
  70 into the buffer visible in the event's window."
  71       (posn-point (event-start event))))
  72
  73   (unless (fboundp 'error-message-string)
  74     ;; Emacs function missing in XEmacs.
  75     (defun error-message-string (obj)
  76       "Convert an error value to an error message."
  77       (let ((buf (get-buffer-create " *error-message*")))
  78         (erase-buffer buf)
  79         (display-error obj buf)
  80         (buffer-string buf)))))
  81
  82 ;;; Customization.
  83
  84 (defgroup widgets nil
  85   "Customization support for the Widget Library."
  86   :link '(custom-manual "(widget)Top")
  87   :link '(url-link :tag "Development Page"
  88                    "http://www.dina.kvl.dk/~abraham/custom/")
  89   :prefix "widget-"
  90   :group 'extensions
  91   :group 'faces
  92   :group 'hypermedia)
  93
  94 (defface widget-documentation-face '((((class color)
  95                                        (background dark))
  96                                       (:foreground "lime green"))
  97                                      (((class color)
  98                                        (background light))
  99                                       (:foreground "dark green"))
 100                                      (t nil))
 101   "Face used for documentation text."
 102   :group 'widgets)
 103
 104 (defface widget-button-face '((t (:bold t)))
 105   "Face used for widget buttons."
 106   :group 'widgets)
 107
 108 (defcustom widget-mouse-face 'highlight
 109   "Face used for widget buttons when the mouse is above them."
 110   :type 'face
 111   :group 'widgets)
 112
 113 (defface widget-field-face '((((class grayscale color)
 114                                (background light))
 115                               (:background "light gray"))
 116                              (((class grayscale color)
 117                                (background dark))
 118                               (:background "dark gray"))
 119                              (t
 120                               (:italic t)))
 121   "Face used for editable fields."
 122   :group 'widgets)
 123
 124 (defcustom widget-menu-max-size 40
 125   "Largest number of items allowed in a popup-menu.
 126 Larger menus are read through the minibuffer."
 127   :group 'widgets
 128   :type 'integer)
 129
 130 ;;; Utility functions.
 131 ;;
 132 ;; These are not really widget specific.
 133
 134 (defsubst widget-plist-member (plist prop)
 135   ;; Return non-nil if PLIST has the property PROP.
 136   ;; PLIST is a property list, which is a list of the form
 137   ;; (PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol.
 138   ;; Unlike `plist-get', this allows you to distinguish between a missing
 139   ;; property and a property with the value nil.
 140   ;; The value is actually the tail of PLIST whose car is PROP.
 141   (while (and plist (not (eq (car plist) prop)))
 142     (setq plist (cdr (cdr plist))))
 143   plist)
 144
 145 (defun widget-princ-to-string (object)
 146   ;; Return string representation of OBJECT, any Lisp object.
 147   ;; No quoting characters are used; no delimiters are printed around
 148   ;; the contents of strings.
 149   (save-excursion
 150     (set-buffer (get-buffer-create " *widget-tmp*"))
 151     (erase-buffer)
 152     (let ((standard-output (current-buffer)))
 153       (princ object))
 154     (buffer-string)))
 155
 156 (defun widget-clear-undo ()
 157   "Clear all undo information."
 158   (buffer-disable-undo (current-buffer))
 159   (buffer-enable-undo))
 160
 161 (defun widget-choose (title items &optional event)
 162   "Choose an item from a list.
 163
 164 First argument TITLE is the name of the list.
 165 Second argument ITEMS is an alist (NAME . VALUE).
 166 Optional third argument EVENT is an input event.
 167
 168 The user is asked to choose between each NAME from the items alist,
 169 and the VALUE of the chosen element will be returned.  If EVENT is a
 170 mouse event, and the number of elements in items is less than
 171 `widget-menu-max-size', a popup menu will be used, otherwise the
 172 minibuffer."
 173   (cond ((and (< (length items) widget-menu-max-size)
 174               event (fboundp 'x-popup-menu) window-system)
 175          ;; We are in Emacs-19, pressed by the mouse
 176          (x-popup-menu event
 177                        (list title (cons "" items))))
 178         ((and (< (length items) widget-menu-max-size)
 179               event (fboundp 'popup-menu) window-system)
 180          ;; We are in XEmacs, pressed by the mouse
 181          (let ((val (get-popup-menu-response
 182                      (cons title
 183                            (mapcar
 184                             (function
 185                              (lambda (x)
 186                                (vector (car x) (list (car x)) t)))
 187                             items)))))
 188            (setq val (and val
 189                           (listp (event-object val))
 190                           (stringp (car-safe (event-object val)))
 191                           (car (event-object val))))
 192            (cdr (assoc val items))))
 193         (t
 194          (let ((val (completing-read (concat title ": ") items nil t)))
 195            (if (stringp val)
 196                (let ((try (try-completion val items)))
 197                  (when (stringp try)
 198                    (setq val try))
 199                  (cdr (assoc val items)))
 200              nil)))))
 201
 202 (defun widget-get-sibling (widget)
 203   "Get the item WIDGET is assumed to toggle.
 204 This is only meaningful for radio buttons or checkboxes in a list."
 205   (let* ((parent (widget-get widget :parent))
 206          (children (widget-get parent :children))
 207          child)
 208     (catch 'child
 209       (while children
 210         (setq child (car children)
 211               children (cdr children))
 212         (when (eq (widget-get child :button) widget)
 213           (throw 'child child)))
 214       nil)))
 215
 216 ;;; Widget text specifications.
 217 ;;
 218 ;; These functions are for specifying text properties.
 219
 220 (defun widget-specify-none (from to)
 221   ;; Clear all text properties between FROM and TO.
 222   (set-text-properties from to nil))
 223
 224 (defun widget-specify-text (from to)
 225   ;; Default properties.
 226   (add-text-properties from to (list 'read-only t
 227                                      'front-sticky t
 228                                      'start-open t
 229                                      'end-open t
 230                                      'rear-nonsticky nil)))
 231
 232 (defun widget-specify-field (widget from to)
 233   ;; Specify editable button for WIDGET between FROM and TO.
 234   (widget-specify-field-update widget from to)
 235
 236   ;; Make it possible to edit the front end of the field.
 237   (add-text-properties (1- from) from (list 'rear-nonsticky t
 238                                               'end-open t
 239                                               'invisible t))
 240   (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
 241             (widget-get widget :hide-front-space))
 242     ;; WARNING: This is going to lose horrible if the character just
 243     ;; before the field can be modified (e.g. if it belongs to a
 244     ;; choice widget).  We try to compensate by checking the format
 245     ;; string, and hope the user hasn't changed the :create method.
 246     (widget-make-intangible (- from 2) from 'end-open))
 247
 248   ;; Make it possible to edit back end of the field.
 249   (add-text-properties to (1+ to) (list 'front-sticky nil
 250                                         'read-only t
 251                                         'start-open t))
 252
 253   (cond ((widget-get widget :size)
 254          (put-text-property to (1+ to) 'invisible t)
 255          (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
 256                    (widget-get widget :hide-rear-space))
 257            ;; WARNING: This is going to lose horrible if the character just
 258            ;; after the field can be modified (e.g. if it belongs to a
 259            ;; choice widget).  We try to compensate by checking the format
 260            ;; string, and hope the user hasn't changed the :create method.
 261            (widget-make-intangible to (+ to 2) 'start-open)))
 262         ((string-match "XEmacs" emacs-version)
 263          ;; XEmacs does not allow you to insert before a read-only
 264          ;; character, even if it is start.open.
 265          ;; XEmacs does allow you to delete an read-only extent, so
 266          ;; making the terminating newline read only doesn't help.
 267          ;; I tried putting an invisible intangible read-only space
 268          ;; before the newline, which gave really weird effects.
 269          ;; So for now, we just have trust the user not to delete the
 270          ;; newline.
 271          (put-text-property to (1+ to) 'read-only nil))))
 272
 273 (defun widget-specify-field-update (widget from to)
 274   ;; Specify editable button for WIDGET between FROM and TO.
 275   (let ((map (widget-get widget :keymap))
 276         (secret (widget-get widget :secret))
 277         (secret-to to)
 278         (size (widget-get widget :size))
 279         (face (or (widget-get widget :value-face)
 280                   'widget-field-face))
 281         (help-echo (widget-get widget :help-echo))
 282         (help-property (if (featurep 'balloon-help)
 283                            'balloon-help
 284                          'help-echo)))
 285     (unless (or (stringp help-echo) (null help-echo))
 286       (setq help-echo 'widget-mouse-help))
 287
 288     (when secret
 289       (while (and size
 290                   (not (zerop size))
 291                   (> secret-to from)
 292                   (eq (char-after (1- secret-to)) ?\ ))
 293         (setq secret-to (1- secret-to)))
 294
 295       (save-excursion
 296         (goto-char from)
 297         (while (< (point) secret-to)
 298           (let ((old (get-text-property (point) 'secret)))
 299             (when old
 300               (subst-char-in-region (point) (1+ (point)) secret old)))
 301           (forward-char))))
 302
 303     (set-text-properties from to (list 'field widget
 304                                        'read-only nil
 305                                        'keymap map
 306                                        'local-map map
 307                                        help-property help-echo
 308                                        'face face))
 309
 310     (when secret
 311       (save-excursion
 312         (goto-char from)
 313         (while (< (point) secret-to)
 314           (let ((old (following-char)))
 315             (subst-char-in-region (point) (1+ (point)) old secret)
 316             (put-text-property (point) (1+ (point)) 'secret old))
 317           (forward-char))))
 318
 319     (unless (widget-get widget :size)
 320       (add-text-properties to (1+ to) (list 'field widget
 321                                             help-property help-echo
 322                                             'face face)))
 323     (add-text-properties to (1+ to) (list 'local-map map
 324                                           'keymap map))))
 325
 326 (defun widget-specify-button (widget from to)
 327   ;; Specify button for WIDGET between FROM and TO.
 328   (let ((face (widget-apply widget :button-face-get))
 329         (help-echo (widget-get widget :help-echo))
 330         (help-property (if (featurep 'balloon-help)
 331                            'balloon-help
 332                          'help-echo)))
 333     (unless (or (null help-echo) (stringp help-echo))
 334       (setq help-echo 'widget-mouse-help))
 335     (add-text-properties from to (list 'button widget
 336                                        'mouse-face widget-mouse-face
 337                                        'start-open t
 338                                        'end-open t
 339                                        help-property help-echo
 340                                        'face face))))
 341
 342 (defun widget-mouse-help (extent)
 343   "Find mouse help string for button in extent."
 344   (let* ((widget (widget-at (extent-start-position extent)))
 345          (help-echo (and widget (widget-get widget :help-echo))))
 346     (cond ((stringp help-echo)
 347            help-echo)
 348           ((and (symbolp help-echo) (fboundp help-echo)
 349                 (stringp (setq help-echo (funcall help-echo widget))))
 350            help-echo)
 351           (t
 352            (format "(widget %S :help-echo %S)" widget help-echo)))))
 353
 354 (defun widget-specify-sample (widget from to)
 355   ;; Specify sample for WIDGET between FROM and TO.
 356   (let ((face (widget-apply widget :sample-face-get)))
 357     (when face
 358       (add-text-properties from to (list 'start-open t
 359                                          'end-open t
 360                                          'face face)))))
 361
 362 (defun widget-specify-doc (widget from to)
 363   ;; Specify documentation for WIDGET between FROM and TO.
 364   (add-text-properties from to (list 'widget-doc widget
 365                                      'face 'widget-documentation-face)))
 366
 367 (defmacro widget-specify-insert (&rest form)
 368   ;; Execute FORM without inheriting any text properties.
 369   `(save-restriction
 370      (let ((inhibit-read-only t)
 371            result
 372            after-change-functions)
 373        (insert "<>")
 374        (narrow-to-region (- (point) 2) (point))
 375        (widget-specify-none (point-min) (point-max))
 376        (goto-char (1+ (point-min)))
 377        (setq result (progn ,@form))
 378        (delete-region (point-min) (1+ (point-min)))
 379        (delete-region (1- (point-max)) (point-max))
 380        (goto-char (point-max))
 381        result)))
 382
 383 ;;; Widget Properties.
 384
 385 (defsubst widget-type (widget)
 386   "Return the type of WIDGET, a symbol."
 387   (car widget))
 388
 389 (defun widget-put (widget property value)
 390   "In WIDGET set PROPERTY to VALUE.
 391 The value can later be retrived with `widget-get'."
 392   (setcdr widget (plist-put (cdr widget) property value)))
 393
 394 (defun widget-get (widget property)
 395   "In WIDGET, get the value of PROPERTY.
 396 The value could either be specified when the widget was created, or
 397 later with `widget-put'."
 398   (let ((missing t)
 399         value tmp)
 400     (while missing
 401       (cond ((setq tmp (widget-plist-member (cdr widget) property))
 402              (setq value (car (cdr tmp))
 403                    missing nil))
 404             ((setq tmp (car widget))
 405              (setq widget (get tmp 'widget-type)))
 406             (t
 407              (setq missing nil))))
 408     value))
 409
 410 (defun widget-member (widget property)
 411   "Non-nil iff there is a definition in WIDGET for PROPERTY."
 412   (cond ((widget-plist-member (cdr widget) property)
 413          t)
 414         ((car widget)
 415          (widget-member (get (car widget) 'widget-type) property))
 416         (t nil)))
 417
 418 (defun widget-apply (widget property &rest args)
 419   "Apply the value of WIDGET's PROPERTY to the widget itself.
 420 ARGS are passed as extra arguments to the function."
 421   (apply (widget-get widget property) widget args))
 422
 423 (defun widget-value (widget)
 424   "Extract the current value of WIDGET."
 425   (widget-apply widget
 426                 :value-to-external (widget-apply widget :value-get)))
 427
 428 (defun widget-value-set (widget value)
 429   "Set the current value of WIDGET to VALUE."
 430   (widget-apply widget
 431                 :value-set (widget-apply widget
 432                                          :value-to-internal value)))
 433
 434 (defun widget-match-inline (widget vals)
 435   ;; In WIDGET, match the start of VALS.
 436   (cond ((widget-get widget :inline)
 437          (widget-apply widget :match-inline vals))
 438         ((and vals
 439               (widget-apply widget :match (car vals)))
 440          (cons (list (car vals)) (cdr vals)))
 441         (t nil)))
 442
 443 ;;; Glyphs.
 444
 445 (defcustom widget-glyph-directory (concat data-directory "custom/")
 446   "Where widget glyphs are located.
 447 If this variable is nil, widget will try to locate the directory
 448 automatically. This does not work yet."
 449   :group 'widgets
 450   :type 'directory)
 451
 452 (defcustom widget-glyph-enable t
 453   "If non nil, use glyphs in images when available."
 454   :group 'widgets
 455   :type 'boolean)
 456
 457 (defun widget-glyph-insert (widget tag image)
 458   "In WIDGET, insert the text TAG or, if supported, IMAGE.
 459 IMAGE should either be a glyph, or a name sans extension of an xpm or
 460 xbm file located in `widget-glyph-directory'.
 461
 462 WARNING: If you call this with a glyph, and you want theuser to be
 463 able to activate the glyph, make sure it is unique.  If you use the
 464 same glyph for multiple widgets, "
 465   (cond ((not (and (string-match "XEmacs" emacs-version)
 466                    widget-glyph-enable
 467                    (fboundp 'make-glyph)
 468                    image))
 469          ;; We don't want or can't use glyphs.
 470          (insert tag))
 471         ((and (fboundp 'glyphp)
 472               (glyphp image))
 473          ;; Already a glyph.  Insert it.
 474          (widget-glyph-insert-glyph widget tag image))
 475         (t
 476          ;; A string.  Look it up in.
 477          (let ((file (concat widget-glyph-directory
 478                             (if (string-match "/\\'" widget-glyph-directory)
 479                                 ""
 480                               "/")
 481                             image
 482                             (if (featurep 'xpm) ".xpm" ".xbm"))))
 483            (if (file-readable-p file)
 484                (widget-glyph-insert-glyph widget tag (make-glyph file))
 485              ;; File not readable, give up.
 486              (insert tag))))))
 487
 488 (defun widget-glyph-insert-glyph (widget tag glyph)
 489   "In WIDGET, with alternative text TAG, insert GLYPH."
 490   (set-glyph-image glyph (cons 'tty tag))
 491   (set-glyph-property glyph 'widget widget)
 492   (insert "*")
 493   (add-text-properties (1- (point)) (point)
 494                        (list 'invisible t
 495                              'end-glyph glyph))
 496   (let ((help-echo (widget-get widget :help-echo)))
 497     (when help-echo
 498       (let ((extent (extent-at (1- (point)) nil 'end-glyph))
 499             (help-property (if (featurep 'balloon-help)
 500                                'balloon-help
 501                              'help-echo)))
 502         (set-extent-property extent help-property (if (stringp help-echo)
 503                                                       help-echo
 504                                                     'widget-mouse-help))))))
 505
 506 ;;; Creating Widgets.
 507
 508 ;;;###autoload
 509 (defun widget-create (type &rest args)
 510   "Create widget of TYPE.
 511 The optional ARGS are additional keyword arguments."
 512   (let ((widget (apply 'widget-convert type args)))
 513     (widget-apply widget :create)
 514     widget))
 515
 516 (defun widget-create-child-and-convert (parent type &rest args)
 517   "As part of the widget PARENT, create a child widget TYPE.
 518 The child is converted, using the keyword arguments ARGS."
 519   (let ((widget (apply 'widget-convert type args)))
 520     (widget-put widget :parent parent)
 521     (unless (widget-get widget :indent)
 522       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 523                                     (or (widget-get widget :extra-offset) 0)
 524                                     (widget-get parent :offset))))
 525     (widget-apply widget :create)
 526     widget))
 527
 528 (defun widget-create-child (parent type)
 529   "Create widget of TYPE."
 530   (let ((widget (copy-list type)))
 531     (widget-put widget :parent parent)
 532     (unless (widget-get widget :indent)
 533       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 534                                     (or (widget-get widget :extra-offset) 0)
 535                                     (widget-get parent :offset))))
 536     (widget-apply widget :create)
 537     widget))
 538
 539 (defun widget-create-child-value (parent type value)
 540   "Create widget of TYPE with value VALUE."
 541   (let ((widget (copy-list type)))
 542     (widget-put widget :value (widget-apply widget :value-to-internal value))
 543     (widget-put widget :parent parent)
 544     (unless (widget-get widget :indent)
 545       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 546                                     (or (widget-get widget :extra-offset) 0)
 547                                     (widget-get parent :offset))))
 548     (widget-apply widget :create)
 549     widget))
 550
 551 ;;;###autoload
 552 (defun widget-delete (widget)
 553   "Delete WIDGET."
 554   (widget-apply widget :delete))
 555
 556 (defun widget-convert (type &rest args)
 557   "Convert TYPE to a widget without inserting it in the buffer.
 558 The optional ARGS are additional keyword arguments."
 559   ;; Don't touch the type.
 560   (let* ((widget (if (symbolp type)
 561                      (list type)
 562                    (copy-list type)))
 563          (current widget)
 564          (keys args))
 565     ;; First set the :args keyword.
 566     (while (cdr current)                ;Look in the type.
 567       (let ((next (car (cdr current))))
 568         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 569             (setq current (cdr (cdr current)))
 570           (setcdr current (list :args (cdr current)))
 571           (setq current nil))))
 572     (while args                         ;Look in the args.
 573       (let ((next (nth 0 args)))
 574         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 575             (setq args (nthcdr 2 args))
 576           (widget-put widget :args args)
 577           (setq args nil))))
 578     ;; Then Convert the widget.
 579     (setq type widget)
 580     (while type
 581       (let ((convert-widget (plist-get (cdr type) :convert-widget)))
 582         (if convert-widget
 583             (setq widget (funcall convert-widget widget))))
 584       (setq type (get (car type) 'widget-type)))
 585     ;; Finally set the keyword args.
 586     (while keys
 587       (let ((next (nth 0 keys)))
 588         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 589             (progn
 590               (widget-put widget next (nth 1 keys))
 591               (setq keys (nthcdr 2 keys)))
 592           (setq keys nil))))
 593     ;; Convert the :value to internal format.
 594     (if (widget-member widget :value)
 595         (let ((value (widget-get widget :value)))
 596           (widget-put widget
 597                       :value (widget-apply widget :value-to-internal value))))
 598     ;; Return the newly create widget.
 599     widget))
 600
 601 (defun widget-insert (&rest args)
 602   "Call `insert' with ARGS and make the text read only."
 603   (let ((inhibit-read-only t)
 604         after-change-functions
 605         (from (point)))
 606     (apply 'insert args)
 607     (widget-specify-text from (point))))
 608
 609 ;;; Keymap and Commands.
 610
 611 (defvar widget-keymap nil
 612   "Keymap containing useful binding for buffers containing widgets.
 613 Recommended as a parent keymap for modes using widgets.")
 614
 615 (unless widget-keymap
 616   (setq widget-keymap (make-sparse-keymap))
 617   (define-key widget-keymap "\C-k" 'widget-kill-line)
 618   (define-key widget-keymap "\t" 'widget-forward)
 619   (define-key widget-keymap "\M-\t" 'widget-backward)
 620   (define-key widget-keymap [(shift tab)] 'widget-backward)
 621   (define-key widget-keymap [backtab] 'widget-backward)
 622   (if (string-match "XEmacs" (emacs-version))
 623       (progn
 624         (define-key widget-keymap [button2] 'widget-button-click)
 625         (define-key widget-keymap [button1] 'widget-button1-click))
 626     (define-key widget-keymap [mouse-2] 'ignore)
 627     (define-key widget-keymap [down-mouse-2] 'widget-button-click))
 628   (define-key widget-keymap "\C-m" 'widget-button-press))
 629
 630 (defvar widget-global-map global-map
 631   "Keymap used for events the widget does not handle themselves.")
 632 (make-variable-buffer-local 'widget-global-map)
 633
 634 (defvar widget-field-keymap nil
 635   "Keymap used inside an editable field.")
 636
 637 (unless widget-field-keymap
 638   (setq widget-field-keymap (copy-keymap widget-keymap))
 639   (unless (string-match "XEmacs" (emacs-version))
 640     (define-key widget-field-keymap [menu-bar] 'nil))
 641   (define-key widget-field-keymap "\C-m" 'widget-field-activate)
 642   (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
 643   (define-key widget-field-keymap "\C-e" 'widget-end-of-line)
 644   (set-keymap-parent widget-field-keymap global-map))
 645
 646 (defvar widget-text-keymap nil
 647   "Keymap used inside a text field.")
 648
 649 (unless widget-text-keymap
 650   (setq widget-text-keymap (copy-keymap widget-keymap))
 651   (unless (string-match "XEmacs" (emacs-version))
 652     (define-key widget-text-keymap [menu-bar] 'nil))
 653   (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
 654   (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
 655   (set-keymap-parent widget-text-keymap global-map))
 656
 657 (defun widget-field-activate (pos &optional event)
 658   "Activate the ediable field at point."
 659   (interactive "@d")
 660   (let ((field (get-text-property pos 'field)))
 661     (if field
 662         (widget-apply field :action event)
 663       (call-interactively
 664        (lookup-key widget-global-map (this-command-keys))))))
 665
 666 (defun widget-button-click (event)
 667   "Activate button below mouse pointer."
 668   (interactive "@e")
 669   (cond ((and (fboundp 'event-glyph)
 670               (event-glyph event))
 671          (let ((widget (glyph-property (event-glyph event) 'widget)))
 672            (if widget
 673                (widget-apply widget :action event)
 674              (message "You clicked on a glyph."))))
 675         ((event-point event)
 676          (let ((button (get-text-property (event-point event) 'button)))
 677            (if button
 678                (widget-apply button :action event)
 679              (call-interactively
 680               (or (lookup-key widget-global-map [ button2 ])
 681                   (lookup-key widget-global-map [ down-mouse-2 ])
 682                   (lookup-key widget-global-map [ mouse-2]))))))
 683         (t
 684          (message "You clicked somewhere weird."))))
 685
 686 (defun widget-button1-click (event)
 687   "Activate glyph below mouse pointer."
 688   (interactive "@e")
 689   (if (and (fboundp 'event-glyph)
 690            (event-glyph event))
 691       (let ((widget (glyph-property (event-glyph event) 'widget)))
 692         (if widget
 693             (widget-apply widget :action event)
 694           (message "You clicked on a glyph.")))
 695     (call-interactively (lookup-key widget-global-map (this-command-keys)))))
 696
 697 (defun widget-button-press (pos &optional event)
 698   "Activate button at POS."
 699   (interactive "@d")
 700   (let ((button (get-text-property pos 'button)))
 701     (if button
 702         (widget-apply button :action event)
 703       (let ((command (lookup-key widget-global-map (this-command-keys))))
 704         (when (commandp command)
 705           (call-interactively command))))))
 706
 707 (defun widget-move (arg)
 708   "Move point to the ARG next field or button.
 709 ARG may be negative to move backward."
 710   (while (> arg 0)
 711     (setq arg (1- arg))
 712     (let ((next (cond ((get-text-property (point) 'button)
 713                        (next-single-property-change (point) 'button))
 714                       ((get-text-property (point) 'field)
 715                        (next-single-property-change (point) 'field))
 716                       (t
 717                        (point)))))
 718       (if (null next)                   ; Widget extends to end. of buffer
 719           (setq next (point-min)))
 720       (let ((button (next-single-property-change next 'button))
 721             (field (next-single-property-change next 'field)))
 722         (cond ((or (get-text-property next 'button)
 723                    (get-text-property next 'field))
 724                (goto-char next))
 725               ((and button field)
 726                (goto-char (min button field)))
 727               (button (goto-char button))
 728               (field (goto-char field))
 729               (t
 730                (let ((button (next-single-property-change (point-min) 'button))
 731                      (field (next-single-property-change (point-min) 'field)))
 732                  (cond ((and button field) (goto-char (min button field)))
 733                        (button (goto-char button))
 734                        (field (goto-char field))
 735                        (t
 736                         (error "No buttons or fields found"))))))
 737         (setq button (widget-at (point)))
 738         (if (and button (widget-get button :tab-order)
 739                  (< (widget-get button :tab-order) 0))
 740             (setq arg (1+ arg))))))
 741   (while (< arg 0)
 742     (if (= (point-min) (point))
 743         (forward-char 1))
 744     (setq arg (1+ arg))
 745     (let ((previous (cond ((get-text-property (1- (point)) 'button)
 746                            (previous-single-property-change (point) 'button))
 747                           ((get-text-property (1- (point)) 'field)
 748                            (previous-single-property-change (point) 'field))
 749                           (t
 750                            (point)))))
 751       (if (null previous)               ; Widget extends to beg. of buffer
 752           (setq previous (point-max)))
 753       (let ((button (previous-single-property-change previous 'button))
 754             (field (previous-single-property-change previous 'field)))
 755         (cond ((and button field)
 756                (goto-char (max button field)))
 757               (button (goto-char button))
 758               (field (goto-char field))
 759               (t
 760                (let ((button (previous-single-property-change
 761                               (point-max) 'button))
 762                      (field (previous-single-property-change
 763                              (point-max) 'field)))
 764                  (cond ((and button field) (goto-char (max button field)))
 765                        (button (goto-char button))
 766                        (field (goto-char field))
 767                        (t
 768                         (error "No buttons or fields found"))))))))
 769     (let ((button (previous-single-property-change (point) 'button))
 770           (field (previous-single-property-change (point) 'field)))
 771       (cond ((and button field)
 772              (goto-char (max button field)))
 773             (button (goto-char button))
 774             (field (goto-char field)))
 775       (setq button (widget-at (point)))
 776       (if (and button (widget-get button :tab-order)
 777                (< (widget-get button :tab-order) 0))
 778           (setq arg (1- arg)))))
 779   (widget-echo-help (point))
 780   (run-hooks 'widget-move-hook))
 781
 782 (defun widget-forward (arg)
 783   "Move point to the next field or button.
 784 With optional ARG, move across that many fields."
 785   (interactive "p")
 786   (run-hooks 'widget-forward-hook)
 787   (widget-move arg))
 788
 789 (defun widget-backward (arg)
 790   "Move point to the previous field or button.
 791 With optional ARG, move across that many fields."
 792   (interactive "p")
 793   (run-hooks 'widget-backward-hook)
 794   (widget-move (- arg)))
 795
 796 (defun widget-beginning-of-line ()
 797   "Go to beginning of field or beginning of line, whichever is first."
 798   (interactive)
 799   (let ((bol (save-excursion (beginning-of-line) (point)))
 800         (prev (previous-single-property-change (point) 'field)))
 801     (goto-char (max bol (or prev bol)))))
 802
 803 (defun widget-end-of-line ()
 804   "Go to end of field or end of line, whichever is first."
 805   (interactive)
 806   (let ((bol (save-excursion (end-of-line) (point)))
 807         (prev (next-single-property-change (point) 'field)))
 808     (goto-char (min bol (or prev bol)))))
 809
 810 (defun widget-kill-line ()
 811   "Kill to end of field or end of line, whichever is first."
 812   (interactive)
 813   (let ((field (get-text-property (point) 'field))
 814         (newline (save-excursion (search-forward "\n")))
 815         (next (next-single-property-change (point) 'field)))
 816     (if (and field (> newline next))
 817         (kill-region (point) next)
 818       (call-interactively 'kill-line))))
 819
 820 ;;; Setting up the buffer.
 821
 822 (defvar widget-field-new nil)
 823 ;; List of all newly created editable fields in the buffer.
 824 (make-variable-buffer-local 'widget-field-new)
 825
 826 (defvar widget-field-list nil)
 827 ;; List of all editable fields in the buffer.
 828 (make-variable-buffer-local 'widget-field-list)
 829
 830 (defun widget-setup ()
 831   "Setup current buffer so editing string widgets works."
 832   (let ((inhibit-read-only t)
 833         (after-change-functions nil)
 834         field)
 835     (while widget-field-new
 836       (setq field (car widget-field-new)
 837             widget-field-new (cdr widget-field-new)
 838             widget-field-list (cons field widget-field-list))
 839       (let ((from (widget-get field :value-from))
 840             (to (widget-get field :value-to)))
 841         (widget-specify-field field from to)
 842         (move-marker from (1- from))
 843         (move-marker to (1+ to)))))
 844   (widget-clear-undo)
 845   ;; We need to maintain text properties and size of the editing fields.
 846   (make-local-variable 'after-change-functions)
 847   (if widget-field-list
 848       (setq after-change-functions '(widget-after-change))
 849     (setq after-change-functions nil)))
 850
 851 (defvar widget-field-last nil)
 852 ;; Last field containing point.
 853 (make-variable-buffer-local 'widget-field-last)
 854
 855 (defvar widget-field-was nil)
 856 ;; The widget data before the change.
 857 (make-variable-buffer-local 'widget-field-was)
 858
 859 (defun widget-field-find (pos)
 860   ;; Find widget whose editing field is located at POS.
 861   ;; Return nil if POS is not inside and editing field.
 862   ;;
 863   ;; This is only used in `widget-field-modified', since ordinarily
 864   ;; you would just test the field property.
 865   (let ((fields widget-field-list)
 866         field found)
 867     (while fields
 868       (setq field (car fields)
 869             fields (cdr fields))
 870       (let ((from (widget-get field :value-from))
 871             (to (widget-get field :value-to)))
 872         (if (and from to (< from pos) (> to  pos))
 873             (setq fields nil
 874                   found field))))
 875     found))
 876
 877 (defun widget-after-change (from to old)
 878   ;; Adjust field size and text properties.
 879   (condition-case nil
 880       (let ((field (widget-field-find from))
 881             (inhibit-read-only t))
 882         (cond ((null field))
 883               ((not (eq field (widget-field-find to)))
 884                (debug)
 885                (message "Error: `widget-after-change' called on two fields"))
 886               (t
 887                (let ((size (widget-get field :size)))
 888                  (if size
 889                      (let ((begin (1+ (widget-get field :value-from)))
 890                            (end (1- (widget-get field :value-to))))
 891                        (widget-specify-field-update field begin end)
 892                        (cond ((< (- end begin) size)
 893                               ;; Field too small.
 894                               (save-excursion
 895                                 (goto-char end)
 896                                 (insert-char ?\  (- (+ begin size) end))
 897                                 (widget-specify-field-update field
 898                                                              begin
 899                                                              (+ begin size))))
 900                              ((> (- end begin) size)
 901                               ;; Field too large and
 902                               (if (or (< (point) (+ begin size))
 903                                       (> (point) end))
 904                                   ;; Point is outside extra space.
 905                                   (setq begin (+ begin size))
 906                                 ;; Point is within the extra space.
 907                                 (setq begin (point)))
 908                               (save-excursion
 909                                 (goto-char end)
 910                                 (while (and (eq (preceding-char) ?\ )
 911                                             (> (point) begin))
 912                                   (delete-backward-char 1))))))
 913                    (widget-specify-field-update field from to)))
 914                (widget-apply field :notify field))))
 915     (error (debug))))
 916
 917 ;;; Widget Functions
 918 ;;
 919 ;; These functions are used in the definition of multiple widgets.
 920
 921 (defun widget-children-value-delete (widget)
 922   "Delete all :children and :buttons in WIDGET."
 923   (mapcar 'widget-delete (widget-get widget :children))
 924   (widget-put widget :children nil)
 925   (mapcar 'widget-delete (widget-get widget :buttons))
 926   (widget-put widget :buttons nil))
 927
 928 (defun widget-types-convert-widget (widget)
 929   "Convert :args as widget types in WIDGET."
 930   (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
 931   widget)
 932
 933 ;;; The `default' Widget.
 934
 935 (define-widget 'default nil
 936   "Basic widget other widgets are derived from."
 937   :value-to-internal (lambda (widget value) value)
 938   :value-to-external (lambda (widget value) value)
 939   :create 'widget-default-create
 940   :indent nil
 941   :offset 0
 942   :format-handler 'widget-default-format-handler
 943   :button-face-get 'widget-default-button-face-get
 944   :sample-face-get 'widget-default-sample-face-get
 945   :delete 'widget-default-delete
 946   :value-set 'widget-default-value-set
 947   :value-inline 'widget-default-value-inline
 948   :menu-tag-get 'widget-default-menu-tag-get
 949   :validate (lambda (widget) nil)
 950   :action 'widget-default-action
 951   :notify 'widget-default-notify)
 952
 953 (defun widget-default-create (widget)
 954   "Create WIDGET at point in the current buffer."
 955   (widget-specify-insert
 956    (let ((from (point))
 957          (tag (widget-get widget :tag))
 958          (glyph (widget-get widget :tag-glyph))
 959          (doc (widget-get widget :doc))
 960          button-begin button-end
 961          sample-begin sample-end
 962          doc-begin doc-end
 963          value-pos)
 964      (insert (widget-get widget :format))
 965      (goto-char from)
 966      ;; Parse escapes in format.
 967      (while (re-search-forward "%\\(.\\)" nil t)
 968        (let ((escape (aref (match-string 1) 0)))
 969          (replace-match "" t t)
 970          (cond ((eq escape ?%)
 971                 (insert "%"))
 972                ((eq escape ?\[)
 973                 (setq button-begin (point)))
 974                ((eq escape ?\])
 975                 (setq button-end (point)))
 976                ((eq escape ?\{)
 977                 (setq sample-begin (point)))
 978                ((eq escape ?\})
 979                 (setq sample-end (point)))
 980                ((eq escape ?n)
 981                 (when (widget-get widget :indent)
 982                   (insert "\n")
 983                   (insert-char ?  (widget-get widget :indent))))
 984                ((eq escape ?t)
 985                 (cond (glyph
 986                        (widget-glyph-insert widget (or tag "image") glyph))
 987                       (tag
 988                        (insert tag))
 989                       (t
 990                        (let ((standard-output (current-buffer)))
 991                          (princ (widget-get widget :value))))))
 992                ((eq escape ?d)
 993                 (when doc
 994                   (setq doc-begin (point))
 995                   (insert doc)
 996                   (while (eq (preceding-char) ?\n)
 997                     (delete-backward-char 1))
 998                   (insert "\n")
 999                   (setq doc-end (point))))
1000                ((eq escape ?v)
1001                 (if (and button-begin (not button-end))
1002                     (widget-apply widget :value-create)
1003                   (setq value-pos (point))))
1004                (t
1005                 (widget-apply widget :format-handler escape)))))
1006      ;; Specify button, sample, and doc, and insert value.
1007      (and button-begin button-end
1008           (widget-specify-button widget button-begin button-end))
1009      (and sample-begin sample-end
1010           (widget-specify-sample widget sample-begin sample-end))
1011      (and doc-begin doc-end
1012           (widget-specify-doc widget doc-begin doc-end))
1013      (when value-pos
1014        (goto-char value-pos)
1015        (widget-apply widget :value-create)))
1016    (let ((from (copy-marker (point-min)))
1017          (to (copy-marker (point-max))))
1018      (widget-specify-text from to)
1019      (set-marker-insertion-type from t)
1020      (set-marker-insertion-type to nil)
1021      (widget-put widget :from from)
1022      (widget-put widget :to to))))
1023
1024 (defun widget-default-format-handler (widget escape)
1025   ;; We recognize the %h escape by default.
1026   (let* ((buttons (widget-get widget :buttons))
1027          (doc-property (widget-get widget :documentation-property))
1028          (doc-try (cond ((widget-get widget :doc))
1029                         ((symbolp doc-property)
1030                          (documentation-property (widget-get widget :value)
1031                                                  doc-property))
1032                         (t
1033                          (funcall doc-property (widget-get widget :value)))))
1034          (doc-text (and (stringp doc-try)
1035                         (> (length doc-try) 1)
1036                         doc-try)))
1037     (cond ((eq escape ?h)
1038            (when doc-text
1039              (and (eq (preceding-char) ?\n)
1040                   (widget-get widget :indent)
1041                   (insert-char ?  (widget-get widget :indent)))
1042              ;; The `*' in the beginning is redundant.
1043              (when (eq (aref doc-text  0) ?*)
1044                (setq doc-text (substring doc-text 1)))
1045              ;; Get rid of trailing newlines.
1046              (when (string-match "\n+\\'" doc-text)
1047                (setq doc-text (substring doc-text 0 (match-beginning 0))))
1048              (push (if (string-match "\n." doc-text)
1049                        ;; Allow multiline doc to be hiden.
1050                        (widget-create-child-and-convert
1051                         widget 'widget-help
1052                         :doc (progn
1053                                (string-match "\\`.*" doc-text)
1054                                (match-string 0 doc-text))
1055                         :widget-doc doc-text
1056                         "?")
1057                      ;; A single line is just inserted.
1058                      (widget-create-child-and-convert
1059                       widget 'item :format "%d" :doc doc-text nil))
1060                    buttons)))
1061           (t
1062            (error "Unknown escape `%c'" escape)))
1063     (widget-put widget :buttons buttons)))
1064
1065 (defun widget-default-button-face-get (widget)
1066   ;; Use :button-face or widget-button-face
1067   (or (widget-get widget :button-face) 'widget-button-face))
1068
1069 (defun widget-default-sample-face-get (widget)
1070   ;; Use :sample-face.
1071   (widget-get widget :sample-face))
1072
1073 (defun widget-default-delete (widget)
1074   ;; Remove widget from the buffer.
1075   (let ((from (widget-get widget :from))
1076         (to (widget-get widget :to))
1077         (inhibit-read-only t)
1078         after-change-functions)
1079     (widget-apply widget :value-delete)
1080     (delete-region from to)
1081     (set-marker from nil)
1082     (set-marker to nil)))
1083
1084 (defun widget-default-value-set (widget value)
1085   ;; Recreate widget with new value.
1086   (save-excursion
1087     (goto-char (widget-get widget :from))
1088     (widget-apply widget :delete)
1089     (widget-put widget :value value)
1090     (widget-apply widget :create)))
1091
1092 (defun widget-default-value-inline (widget)
1093   ;; Wrap value in a list unless it is inline.
1094   (if (widget-get widget :inline)
1095       (widget-value widget)
1096     (list (widget-value widget))))
1097
1098 (defun widget-default-menu-tag-get (widget)
1099   ;; Use tag or value for menus.
1100   (or (widget-get widget :menu-tag)
1101       (widget-get widget :tag)
1102       (widget-princ-to-string (widget-get widget :value))))
1103
1104 (defun widget-default-action (widget &optional event)
1105   ;; Notify the parent when a widget change
1106   (let ((parent (widget-get widget :parent)))
1107     (when parent
1108       (widget-apply parent :notify widget event))))
1109
1110 (defun widget-default-notify (widget child &optional event)
1111   ;; Pass notification to parent.
1112   (widget-default-action widget event))
1113
1114 ;;; The `item' Widget.
1115
1116 (define-widget 'item 'default
1117   "Constant items for inclusion in other widgets."
1118   :convert-widget 'widget-item-convert-widget
1119   :value-create 'widget-item-value-create
1120   :value-delete 'ignore
1121   :value-get 'widget-item-value-get
1122   :match 'widget-item-match
1123   :match-inline 'widget-item-match-inline
1124   :action 'widget-item-action
1125   :format "%t\n")
1126
1127 (defun widget-item-convert-widget (widget)
1128   ;; Initialize :value from :args in WIDGET.
1129   (let ((args (widget-get widget :args)))
1130     (when args
1131       (widget-put widget :value (widget-apply widget
1132                                               :value-to-internal (car args)))
1133       (widget-put widget :args nil)))
1134   widget)
1135
1136 (defun widget-item-value-create (widget)
1137   ;; Insert the printed representation of the value.
1138   (let ((standard-output (current-buffer)))
1139     (princ (widget-get widget :value))))
1140
1141 (defun widget-item-match (widget value)
1142   ;; Match if the value is the same.
1143   (equal (widget-get widget :value) value))
1144
1145 (defun widget-item-match-inline (widget values)
1146   ;; Match if the value is the same.
1147   (let ((value (widget-get widget :value)))
1148     (and (listp value)
1149          (<= (length value) (length values))
1150          (let ((head (subseq values 0 (length value))))
1151            (and (equal head value)
1152                 (cons head (subseq values (length value))))))))
1153
1154 (defun widget-item-action (widget &optional event)
1155   ;; Just notify itself.
1156   (widget-apply widget :notify widget event))
1157
1158 (defun widget-item-value-get (widget)
1159   ;; Items are simple.
1160   (widget-get widget :value))
1161
1162 ;;; The `push-button' Widget.
1163
1164 (defcustom widget-push-button-gui t
1165   "If non nil, use GUI push buttons when available."
1166   :group 'widgets
1167   :type 'boolean)
1168
1169 ;; Cache already created GUI objects.
1170 (defvar widget-push-button-cache nil)
1171
1172 (define-widget 'push-button 'item
1173   "A pushable button."
1174   :value-create 'widget-push-button-value-create
1175   :format "%[%v%]")
1176
1177 (defun widget-push-button-value-create (widget)
1178   ;; Insert text representing the `on' and `off' states.
1179   (let* ((tag (or (widget-get widget :tag)
1180                   (widget-get widget :value)))
1181          (text (concat "[" tag "]"))
1182          (gui (cdr (assoc tag widget-push-button-cache))))
1183     (if (and (fboundp 'make-gui-button)
1184              (fboundp 'make-glyph)
1185              widget-push-button-gui
1186              (fboundp 'device-on-window-system-p)
1187              (device-on-window-system-p)
1188              (string-match "XEmacs" emacs-version))
1189         (progn
1190           (unless gui
1191             (setq gui (make-gui-button tag 'widget-gui-action widget))
1192             (push (cons tag gui) widget-push-button-cache))
1193           (widget-glyph-insert-glyph widget text
1194                                      (make-glyph (car (aref gui 1)))))
1195       (insert text))))
1196
1197 (defun widget-gui-action (widget)
1198   "Apply :action for WIDGET."
1199   (widget-apply widget :action (this-command-keys)))
1200
1201 ;;; The `link' Widget.
1202
1203 (define-widget 'link 'item
1204   "An embedded link."
1205   :help-echo "Follow the link."
1206   :format "%[_%t_%]")
1207
1208 ;;; The `info-link' Widget.
1209
1210 (define-widget 'info-link 'link
1211   "A link to an info file."
1212   :action 'widget-info-link-action)
1213
1214 (defun widget-info-link-action (widget &optional event)
1215   "Open the info node specified by WIDGET."
1216   (Info-goto-node (widget-value widget)))
1217
1218 ;;; The `url-link' Widget.
1219
1220 (define-widget 'url-link 'link
1221   "A link to an www page."
1222   :action 'widget-url-link-action)
1223
1224 (defun widget-url-link-action (widget &optional event)
1225   "Open the url specified by WIDGET."
1226   (require 'browse-url)
1227   (funcall browse-url-browser-function (widget-value widget)))
1228
1229 ;;; The `editable-field' Widget.
1230
1231 (define-widget 'editable-field 'default
1232   "An editable text field."
1233   :convert-widget 'widget-item-convert-widget
1234   :keymap widget-field-keymap
1235   :format "%v"
1236   :value ""
1237   :action 'widget-field-action
1238   :validate 'widget-field-validate
1239   :valid-regexp ""
1240   :error "No match"
1241   :value-create 'widget-field-value-create
1242   :value-delete 'widget-field-value-delete
1243   :value-get 'widget-field-value-get
1244   :match 'widget-field-match)
1245
1246 ;; History of field minibuffer edits.
1247 (defvar widget-field-history nil)
1248
1249 (defun widget-field-action (widget &optional event)
1250   ;; Edit the value in the minibuffer.
1251   (let ((tag (widget-apply widget :menu-tag-get))
1252         (invalid (widget-apply widget :validate)))
1253     (when invalid
1254       (error (widget-get invalid :error)))
1255     (widget-value-set widget
1256                       (widget-apply widget
1257                                     :value-to-external
1258                                     (read-string (concat tag ": ")
1259                                                  (widget-apply
1260                                                   widget
1261                                                   :value-to-internal
1262                                                   (widget-value widget))
1263                                                  'widget-field-history)))
1264     (widget-apply widget :notify widget event)
1265     (widget-setup)))
1266
1267 (defun widget-field-validate (widget)
1268   ;; Valid if the content matches `:valid-regexp'.
1269   (save-excursion
1270     (let ((value (widget-apply widget :value-get))
1271           (regexp (widget-get widget :valid-regexp)))
1272       (if (string-match regexp value)
1273           nil
1274         widget))))
1275
1276 (defun widget-field-value-create (widget)
1277   ;; Create an editable text field.
1278   (insert " ")
1279   (let ((size (widget-get widget :size))
1280         (value (widget-get widget :value))
1281         (from (point)))
1282     (insert value)
1283     (and size
1284          (< (length value) size)
1285          (insert-char ?\  (- size (length value))))
1286     (unless (memq widget widget-field-list)
1287       (setq widget-field-new (cons widget widget-field-new)))
1288     (widget-put widget :value-to (copy-marker (point)))
1289     (set-marker-insertion-type (widget-get widget :value-to) nil)
1290     (if (null size)
1291         (insert ?\n)
1292       (insert ?\ ))
1293     (widget-put widget :value-from (copy-marker from))
1294     (set-marker-insertion-type (widget-get widget :value-from) t)))
1295
1296 (defun widget-field-value-delete (widget)
1297   ;; Remove the widget from the list of active editing fields.
1298   (setq widget-field-list (delq widget widget-field-list))
1299   ;; These are nil if the :format string doesn't contain `%v'.
1300   (when (widget-get widget :value-from)
1301     (set-marker (widget-get widget :value-from) nil))
1302   (when (widget-get widget :value-from)
1303     (set-marker (widget-get widget :value-to) nil)))
1304
1305 (defun widget-field-value-get (widget)
1306   ;; Return current text in editing field.
1307   (let ((from (widget-get widget :value-from))
1308         (to (widget-get widget :value-to))
1309         (size (widget-get widget :size))
1310         (secret (widget-get widget :secret))
1311         (old (current-buffer)))
1312     (if (and from to)
1313         (progn
1314           (set-buffer (marker-buffer from))
1315           (setq from (1+ from)
1316                 to (1- to))
1317           (while (and size
1318                       (not (zerop size))
1319                       (> to from)
1320                       (eq (char-after (1- to)) ?\ ))
1321             (setq to (1- to)))
1322           (let ((result (buffer-substring-no-properties from to)))
1323             (when secret
1324               (let ((index 0))
1325                 (while (< (+ from index) to)
1326                   (aset result index
1327                         (get-text-property (+ from index) 'secret))
1328                   (setq index (1+ index)))))
1329             (set-buffer old)
1330             result))
1331       (widget-get widget :value))))
1332
1333 (defun widget-field-match (widget value)
1334   ;; Match any string.
1335   (stringp value))
1336
1337 ;;; The `text' Widget.
1338
1339 (define-widget 'text 'editable-field
1340   :keymap widget-text-keymap
1341   "A multiline text area.")
1342
1343 ;;; The `menu-choice' Widget.
1344
1345 (define-widget 'menu-choice 'default
1346   "A menu of options."
1347   :convert-widget  'widget-types-convert-widget
1348   :format "%[%t%]: %v"
1349   :case-fold t
1350   :tag "choice"
1351   :void '(item :format "invalid (%t)\n")
1352   :value-create 'widget-choice-value-create
1353   :value-delete 'widget-children-value-delete
1354   :value-get 'widget-choice-value-get
1355   :value-inline 'widget-choice-value-inline
1356   :action 'widget-choice-action
1357   :error "Make a choice"
1358   :validate 'widget-choice-validate
1359   :match 'widget-choice-match
1360   :match-inline 'widget-choice-match-inline)
1361
1362 (defun widget-choice-value-create (widget)
1363   ;; Insert the first choice that matches the value.
1364   (let ((value (widget-get widget :value))
1365         (args (widget-get widget :args))
1366         current)
1367     (while args
1368       (setq current (car args)
1369             args (cdr args))
1370       (when (widget-apply current :match value)
1371         (widget-put widget :children (list (widget-create-child-value
1372                                             widget current value)))
1373         (widget-put widget :choice current)
1374         (setq args nil
1375               current nil)))
1376     (when current
1377       (let ((void (widget-get widget :void)))
1378         (widget-put widget :children (list (widget-create-child-and-convert
1379                                             widget void :value value)))
1380         (widget-put widget :choice void)))))
1381
1382 (defun widget-choice-value-get (widget)
1383   ;; Get value of the child widget.
1384   (widget-value (car (widget-get widget :children))))
1385
1386 (defun widget-choice-value-inline (widget)
1387   ;; Get value of the child widget.
1388   (widget-apply (car (widget-get widget :children)) :value-inline))
1389
1390 (defun widget-choice-action (widget &optional event)
1391   ;; Make a choice.
1392   (let ((args (widget-get widget :args))
1393         (old (widget-get widget :choice))
1394         (tag (widget-apply widget :menu-tag-get))
1395         (completion-ignore-case (widget-get widget :case-fold))
1396         current choices)
1397     ;; Remember old value.
1398     (if (and old (not (widget-apply widget :validate)))
1399         (let* ((external (widget-value widget))
1400                (internal (widget-apply old :value-to-internal external)))
1401           (widget-put old :value internal)))
1402     ;; Find new choice.
1403     (setq current
1404           (cond ((= (length args) 0)
1405                  nil)
1406                 ((= (length args) 1)
1407                  (nth 0 args))
1408                 ((and (= (length args) 2)
1409                       (memq old args))
1410                  (if (eq old (nth 0 args))
1411                      (nth 1 args)
1412                    (nth 0 args)))
1413                 (t
1414                  (while args
1415                    (setq current (car args)
1416                          args (cdr args))
1417                    (setq choices
1418                          (cons (cons (widget-apply current :menu-tag-get)
1419                                      current)
1420                                choices)))
1421                  (widget-choose tag (reverse choices) event))))
1422     (when current
1423       (widget-value-set widget
1424                         (widget-apply current :value-to-external
1425                                       (widget-get current :value)))
1426     (widget-apply widget :notify widget event)
1427     (widget-setup)))
1428   ;; Notify parent.
1429   (widget-apply widget :notify widget event)
1430   (widget-clear-undo))
1431
1432 (defun widget-choice-validate (widget)
1433   ;; Valid if we have made a valid choice.
1434   (let ((void (widget-get widget :void))
1435         (choice (widget-get widget :choice))
1436         (child (car (widget-get widget :children))))
1437     (if (eq void choice)
1438         widget
1439       (widget-apply child :validate))))
1440
1441 (defun widget-choice-match (widget value)
1442   ;; Matches if one of the choices matches.
1443   (let ((args (widget-get widget :args))
1444         current found)
1445     (while (and args (not found))
1446       (setq current (car args)
1447             args (cdr args)
1448             found (widget-apply current :match value)))
1449     found))
1450
1451 (defun widget-choice-match-inline (widget values)
1452   ;; Matches if one of the choices matches.
1453   (let ((args (widget-get widget :args))
1454         current found)
1455     (while (and args (null found))
1456       (setq current (car args)
1457             args (cdr args)
1458             found (widget-match-inline current values)))
1459     found))
1460
1461 ;;; The `toggle' Widget.
1462
1463 (define-widget 'toggle 'item
1464   "Toggle between two states."
1465   :format "%[%v%]\n"
1466   :value-create 'widget-toggle-value-create
1467   :action 'widget-toggle-action
1468   :match (lambda (widget value) t)
1469   :on "on"
1470   :off "off")
1471
1472 (defun widget-toggle-value-create (widget)
1473   ;; Insert text representing the `on' and `off' states.
1474   (if (widget-value widget)
1475       (widget-glyph-insert widget
1476                            (widget-get widget :on)
1477                            (widget-get widget :on-glyph))
1478     (widget-glyph-insert widget
1479                          (widget-get widget :off)
1480                          (widget-get widget :off-glyph))))
1481
1482 (defun widget-toggle-action (widget &optional event)
1483   ;; Toggle value.
1484   (widget-value-set widget (not (widget-value widget)))
1485   (widget-apply widget :notify widget event))
1486
1487 ;;; The `checkbox' Widget.
1488
1489 (define-widget 'checkbox 'toggle
1490   "A checkbox toggle."
1491   :format "%[%v%]"
1492   :on "[X]"
1493   :on-glyph "check1"
1494   :off "[ ]"
1495   :off-glyph "check0")
1496
1497 ;;; The `checklist' Widget.
1498
1499 (define-widget 'checklist 'default
1500   "A multiple choice widget."
1501   :convert-widget 'widget-types-convert-widget
1502   :format "%v"
1503   :offset 4
1504   :entry-format "%b %v"
1505   :menu-tag "checklist"
1506   :greedy nil
1507   :value-create 'widget-checklist-value-create
1508   :value-delete 'widget-children-value-delete
1509   :value-get 'widget-checklist-value-get
1510   :validate 'widget-checklist-validate
1511   :match 'widget-checklist-match
1512   :match-inline 'widget-checklist-match-inline)
1513
1514 (defun widget-checklist-value-create (widget)
1515   ;; Insert all values
1516   (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
1517         (args (widget-get widget :args)))
1518     (while args
1519       (widget-checklist-add-item widget (car args) (assq (car args) alist))
1520       (setq args (cdr args)))
1521     (widget-put widget :children (nreverse (widget-get widget :children)))))
1522
1523 (defun widget-checklist-add-item (widget type chosen)
1524   ;; Create checklist item in WIDGET of type TYPE.
1525   ;; If the item is checked, CHOSEN is a cons whose cdr is the value.
1526   (and (eq (preceding-char) ?\n)
1527        (widget-get widget :indent)
1528        (insert-char ?  (widget-get widget :indent)))
1529   (widget-specify-insert
1530    (let* ((children (widget-get widget :children))
1531           (buttons (widget-get widget :buttons))
1532           (button-args (or (widget-get type :sibling-args)
1533                            (widget-get widget :button-args)))
1534           (from (point))
1535           child button)
1536      (insert (widget-get widget :entry-format))
1537      (goto-char from)
1538      ;; Parse % escapes in format.
1539      (while (re-search-forward "%\\([bv%]\\)" nil t)
1540        (let ((escape (aref (match-string 1) 0)))
1541          (replace-match "" t t)
1542          (cond ((eq escape ?%)
1543                 (insert "%"))
1544                ((eq escape ?b)
1545                 (setq button (apply 'widget-create-child-and-convert
1546                                     widget 'checkbox
1547                                     :value (not (null chosen))
1548                                     button-args)))
1549                ((eq escape ?v)
1550                 (setq child
1551                       (cond ((not chosen)
1552                              (widget-create-child widget type))
1553                             ((widget-get type :inline)
1554                              (widget-create-child-value
1555                               widget type (cdr chosen)))
1556                             (t
1557                              (widget-create-child-value
1558                               widget type (car (cdr chosen)))))))
1559                (t
1560                 (error "Unknown escape `%c'" escape)))))
1561      ;; Update properties.
1562      (and button child (widget-put child :button button))
1563      (and button (widget-put widget :buttons (cons button buttons)))
1564      (and child (widget-put widget :children (cons child children))))))
1565
1566 (defun widget-checklist-match (widget values)
1567   ;; All values must match a type in the checklist.
1568   (and (listp values)
1569        (null (cdr (widget-checklist-match-inline widget values)))))
1570
1571 (defun widget-checklist-match-inline (widget values)
1572   ;; Find the values which match a type in the checklist.
1573   (let ((greedy (widget-get widget :greedy))
1574         (args (copy-list (widget-get widget :args)))
1575         found rest)
1576     (while values
1577       (let ((answer (widget-checklist-match-up args values)))
1578         (cond (answer
1579                (let ((vals (widget-match-inline answer values)))
1580                  (setq found (append found (car vals))
1581                        values (cdr vals)
1582                        args (delq answer args))))
1583               (greedy
1584                (setq rest (append rest (list (car values)))
1585                      values (cdr values)))
1586               (t
1587                (setq rest (append rest values)
1588                      values nil)))))
1589     (cons found rest)))
1590
1591 (defun widget-checklist-match-find (widget vals)
1592   ;; Find the vals which match a type in the checklist.
1593   ;; Return an alist of (TYPE MATCH).
1594   (let ((greedy (widget-get widget :greedy))
1595         (args (copy-list (widget-get widget :args)))
1596         found)
1597     (while vals
1598       (let ((answer (widget-checklist-match-up args vals)))
1599         (cond (answer
1600                (let ((match (widget-match-inline answer vals)))
1601                  (setq found (cons (cons answer (car match)) found)
1602                        vals (cdr match)
1603                        args (delq answer args))))
1604               (greedy
1605                (setq vals (cdr vals)))
1606               (t
1607                (setq vals nil)))))
1608     found))
1609
1610 (defun widget-checklist-match-up (args vals)
1611   ;; Rerturn the first type from ARGS that matches VALS.
1612   (let (current found)
1613     (while (and args (null found))
1614       (setq current (car args)
1615             args (cdr args)
1616             found (widget-match-inline current vals)))
1617     (if found
1618         current
1619       nil)))
1620
1621 (defun widget-checklist-value-get (widget)
1622   ;; The values of all selected items.
1623   (let ((children (widget-get widget :children))
1624         child result)
1625     (while children
1626       (setq child (car children)
1627             children (cdr children))
1628       (if (widget-value (widget-get child :button))
1629           (setq result (append result (widget-apply child :value-inline)))))
1630     result))
1631
1632 (defun widget-checklist-validate (widget)
1633   ;; Ticked chilren must be valid.
1634   (let ((children (widget-get widget :children))
1635         child button found)
1636     (while (and children (not found))
1637       (setq child (car children)
1638             children (cdr children)
1639             button (widget-get child :button)
1640             found (and (widget-value button)
1641                        (widget-apply child :validate))))
1642     found))
1643
1644 ;;; The `option' Widget
1645
1646 (define-widget 'option 'checklist
1647   "An widget with an optional item."
1648   :inline t)
1649
1650 ;;; The `choice-item' Widget.
1651
1652 (define-widget 'choice-item 'item
1653   "Button items that delegate action events to their parents."
1654   :action 'widget-choice-item-action
1655   :format "%[%t%] \n")
1656
1657 (defun widget-choice-item-action (widget &optional event)
1658   ;; Tell parent what happened.
1659   (widget-apply (widget-get widget :parent) :action event))
1660
1661 ;;; The `radio-button' Widget.
1662
1663 (define-widget 'radio-button 'toggle
1664   "A radio button for use in the `radio' widget."
1665   :notify 'widget-radio-button-notify
1666   :format "%[%v%]"
1667   :on "(*)"
1668   :on-glyph "radio1"
1669   :off "( )"
1670   :off-glyph "radio0")
1671
1672 (defun widget-radio-button-notify (widget child &optional event)
1673   ;; Tell daddy.
1674   (widget-apply (widget-get widget :parent) :action widget event))
1675
1676 ;;; The `radio-button-choice' Widget.
1677
1678 (define-widget 'radio-button-choice 'default
1679   "Select one of multiple options."
1680   :convert-widget 'widget-types-convert-widget
1681   :offset 4
1682   :format "%v"
1683   :entry-format "%b %v"
1684   :menu-tag "radio"
1685   :value-create 'widget-radio-value-create
1686   :value-delete 'widget-children-value-delete
1687   :value-get 'widget-radio-value-get
1688   :value-inline 'widget-radio-value-inline
1689   :value-set 'widget-radio-value-set
1690   :error "You must push one of the buttons"
1691   :validate 'widget-radio-validate
1692   :match 'widget-choice-match
1693   :match-inline 'widget-choice-match-inline
1694   :action 'widget-radio-action)
1695
1696 (defun widget-radio-value-create (widget)
1697   ;; Insert all values
1698   (let ((args (widget-get widget :args))
1699         arg)
1700     (while args
1701       (setq arg (car args)
1702             args (cdr args))
1703       (widget-radio-add-item widget arg))))
1704
1705 (defun widget-radio-add-item (widget type)
1706   "Add to radio widget WIDGET a new radio button item of type TYPE."
1707   ;; (setq type (widget-convert type))
1708   (and (eq (preceding-char) ?\n)
1709        (widget-get widget :indent)
1710        (insert-char ?  (widget-get widget :indent)))
1711   (widget-specify-insert
1712    (let* ((value (widget-get widget :value))
1713           (children (widget-get widget :children))
1714           (buttons (widget-get widget :buttons))
1715           (button-args (or (widget-get type :sibling-args)
1716                            (widget-get widget :button-args)))
1717           (from (point))
1718           (chosen (and (null (widget-get widget :choice))
1719                        (widget-apply type :match value)))
1720           child button)
1721      (insert (widget-get widget :entry-format))
1722      (goto-char from)
1723      ;; Parse % escapes in format.
1724      (while (re-search-forward "%\\([bv%]\\)" nil t)
1725        (let ((escape (aref (match-string 1) 0)))
1726          (replace-match "" t t)
1727          (cond ((eq escape ?%)
1728                 (insert "%"))
1729                ((eq escape ?b)
1730                 (setq button (apply 'widget-create-child-and-convert
1731                                     widget 'radio-button
1732                                     :value (not (null chosen))
1733                                     button-args)))
1734                ((eq escape ?v)
1735                 (setq child (if chosen
1736                                 (widget-create-child-value
1737                                  widget type value)
1738                               (widget-create-child widget type))))
1739                (t
1740                 (error "Unknown escape `%c'" escape)))))
1741      ;; Update properties.
1742      (when chosen
1743        (widget-put widget :choice type))
1744      (when button
1745        (widget-put child :button button)
1746        (widget-put widget :buttons (nconc buttons (list button))))
1747      (when child
1748        (widget-put widget :children (nconc children (list child))))
1749      child)))
1750
1751 (defun widget-radio-value-get (widget)
1752   ;; Get value of the child widget.
1753   (let ((chosen (widget-radio-chosen widget)))
1754     (and chosen (widget-value chosen))))
1755
1756 (defun widget-radio-chosen (widget)
1757   "Return the widget representing the chosen radio button."
1758   (let ((children (widget-get widget :children))
1759         current found)
1760     (while children
1761       (setq current (car children)
1762             children (cdr children))
1763       (let* ((button (widget-get current :button))
1764              (value (widget-apply button :value-get)))
1765         (when value
1766           (setq found current
1767                 children nil))))
1768     found))
1769
1770 (defun widget-radio-value-inline (widget)
1771   ;; Get value of the child widget.
1772   (let ((children (widget-get widget :children))
1773         current found)
1774     (while children
1775       (setq current (car children)
1776             children (cdr children))
1777       (let* ((button (widget-get current :button))
1778              (value (widget-apply button :value-get)))
1779         (when value
1780           (setq found (widget-apply current :value-inline)
1781                 children nil))))
1782     found))
1783
1784 (defun widget-radio-value-set (widget value)
1785   ;; We can't just delete and recreate a radio widget, since children
1786   ;; can be added after the original creation and won't be recreated
1787   ;; by `:create'.
1788   (let ((children (widget-get widget :children))
1789         current found)
1790     (while children
1791       (setq current (car children)
1792             children (cdr children))
1793       (let* ((button (widget-get current :button))
1794              (match (and (not found)
1795                          (widget-apply current :match value))))
1796         (widget-value-set button match)
1797         (if match
1798             (widget-value-set current value))
1799         (setq found (or found match))))))
1800
1801 (defun widget-radio-validate (widget)
1802   ;; Valid if we have made a valid choice.
1803   (let ((children (widget-get widget :children))
1804         current found button)
1805     (while (and children (not found))
1806       (setq current (car children)
1807             children (cdr children)
1808             button (widget-get current :button)
1809             found (widget-apply button :value-get)))
1810     (if found
1811         (widget-apply current :validate)
1812       widget)))
1813
1814 (defun widget-radio-action (widget child event)
1815   ;; Check if a radio button was pressed.
1816   (let ((children (widget-get widget :children))
1817         (buttons (widget-get widget :buttons))
1818         current)
1819     (when (memq child buttons)
1820       (while children
1821         (setq current (car children)
1822               children (cdr children))
1823         (let* ((button (widget-get current :button)))
1824           (cond ((eq child button)
1825                  (widget-value-set button t))
1826                 ((widget-value button)
1827                  (widget-value-set button nil)))))))
1828   ;; Pass notification to parent.
1829   (widget-apply widget :notify child event))
1830
1831 ;;; The `insert-button' Widget.
1832
1833 (define-widget 'insert-button 'push-button
1834   "An insert button for the `editable-list' widget."
1835   :tag "INS"
1836   :help-echo "Insert a new item into the list at this position."
1837   :action 'widget-insert-button-action)
1838
1839 (defun widget-insert-button-action (widget &optional event)
1840   ;; Ask the parent to insert a new item.
1841   (widget-apply (widget-get widget :parent)
1842                 :insert-before (widget-get widget :widget)))
1843
1844 ;;; The `delete-button' Widget.
1845
1846 (define-widget 'delete-button 'push-button
1847   "A delete button for the `editable-list' widget."
1848   :tag "DEL"
1849   :help-echo "Delete this item from the list."
1850   :action 'widget-delete-button-action)
1851
1852 (defun widget-delete-button-action (widget &optional event)
1853   ;; Ask the parent to insert a new item.
1854   (widget-apply (widget-get widget :parent)
1855                 :delete-at (widget-get widget :widget)))
1856
1857 ;;; The `editable-list' Widget.
1858
1859 (defcustom widget-editable-list-gui nil
1860   "If non nil, use GUI push-buttons in editable list when available."
1861   :type 'boolean
1862   :group 'widgets)
1863
1864 (define-widget 'editable-list 'default
1865   "A variable list of widgets of the same type."
1866   :convert-widget 'widget-types-convert-widget
1867   :offset 12
1868   :format "%v%i\n"
1869   :format-handler 'widget-editable-list-format-handler
1870   :entry-format "%i %d %v"
1871   :menu-tag "editable-list"
1872   :value-create 'widget-editable-list-value-create
1873   :value-delete 'widget-children-value-delete
1874   :value-get 'widget-editable-list-value-get
1875   :validate 'widget-editable-list-validate
1876   :match 'widget-editable-list-match
1877   :match-inline 'widget-editable-list-match-inline
1878   :insert-before 'widget-editable-list-insert-before
1879   :delete-at 'widget-editable-list-delete-at)
1880
1881 (defun widget-editable-list-format-handler (widget escape)
1882   ;; We recognize the insert button.
1883   (let ((widget-push-button-gui widget-editable-list-gui))
1884     (cond ((eq escape ?i)
1885            (and (widget-get widget :indent)
1886                 (insert-char ?  (widget-get widget :indent)))
1887            (apply 'widget-create-child-and-convert
1888                   widget 'insert-button
1889                   (widget-get widget :append-button-args)))
1890           (t
1891            (widget-default-format-handler widget escape)))))
1892
1893 (defun widget-editable-list-value-create (widget)
1894   ;; Insert all values
1895   (let* ((value (widget-get widget :value))
1896          (type (nth 0 (widget-get widget :args)))
1897          (inlinep (widget-get type :inline))
1898          children)
1899     (widget-put widget :value-pos (copy-marker (point)))
1900     (set-marker-insertion-type (widget-get widget :value-pos) t)
1901     (while value
1902       (let ((answer (widget-match-inline type value)))
1903         (if answer
1904             (setq children (cons (widget-editable-list-entry-create
1905                                   widget
1906                                   (if inlinep
1907                                       (car answer)
1908                                     (car (car answer)))
1909                                   t)
1910                                  children)
1911                   value (cdr answer))
1912           (setq value nil))))
1913     (widget-put widget :children (nreverse children))))
1914
1915 (defun widget-editable-list-value-get (widget)
1916   ;; Get value of the child widget.
1917   (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
1918                          (widget-get widget :children))))
1919
1920 (defun widget-editable-list-validate (widget)
1921   ;; All the chilren must be valid.
1922   (let ((children (widget-get widget :children))
1923         child found)
1924     (while (and children (not found))
1925       (setq child (car children)
1926             children (cdr children)
1927             found (widget-apply child :validate)))
1928     found))
1929
1930 (defun widget-editable-list-match (widget value)
1931   ;; Value must be a list and all the members must match the type.
1932   (and (listp value)
1933        (null (cdr (widget-editable-list-match-inline widget value)))))
1934
1935 (defun widget-editable-list-match-inline (widget value)
1936   (let ((type (nth 0 (widget-get widget :args)))
1937         (ok t)
1938         found)
1939     (while (and value ok)
1940       (let ((answer (widget-match-inline type value)))
1941         (if answer
1942             (setq found (append found (car answer))
1943                   value (cdr answer))
1944           (setq ok nil))))
1945     (cons found value)))
1946
1947 (defun widget-editable-list-insert-before (widget before)
1948   ;; Insert a new child in the list of children.
1949   (save-excursion
1950     (let ((children (widget-get widget :children))
1951           (inhibit-read-only t)
1952           after-change-functions)
1953       (cond (before
1954              (goto-char (widget-get before :entry-from)))
1955             (t
1956              (goto-char (widget-get widget :value-pos))))
1957       (let ((child (widget-editable-list-entry-create
1958                     widget nil nil)))
1959         (when (< (widget-get child :entry-from) (widget-get widget :from))
1960           (set-marker (widget-get widget :from)
1961                       (widget-get child :entry-from)))
1962         (widget-specify-text (widget-get child :entry-from)
1963                              (widget-get child :entry-to))
1964         (if (eq (car children) before)
1965             (widget-put widget :children (cons child children))
1966           (while (not (eq (car (cdr children)) before))
1967             (setq children (cdr children)))
1968           (setcdr children (cons child (cdr children)))))))
1969   (widget-setup)
1970   (widget-apply widget :notify widget))
1971
1972 (defun widget-editable-list-delete-at (widget child)
1973   ;; Delete child from list of children.
1974   (save-excursion
1975     (let ((buttons (copy-list (widget-get widget :buttons)))
1976           button
1977           (inhibit-read-only t)
1978           after-change-functions)
1979       (while buttons
1980         (setq button (car buttons)
1981               buttons (cdr buttons))
1982         (when (eq (widget-get button :widget) child)
1983           (widget-put widget
1984                       :buttons (delq button (widget-get widget :buttons)))
1985           (widget-delete button))))
1986     (let ((entry-from (widget-get child :entry-from))
1987           (entry-to (widget-get child :entry-to))
1988           (inhibit-read-only t)
1989           after-change-functions)
1990       (widget-delete child)
1991       (delete-region entry-from entry-to)
1992       (set-marker entry-from nil)
1993       (set-marker entry-to nil))
1994     (widget-put widget :children (delq child (widget-get widget :children))))
1995   (widget-setup)
1996   (widget-apply widget :notify widget))
1997
1998 (defun widget-editable-list-entry-create (widget value conv)
1999   ;; Create a new entry to the list.
2000   (let ((type (nth 0 (widget-get widget :args)))
2001         (widget-push-button-gui widget-editable-list-gui)
2002         child delete insert)
2003     (widget-specify-insert
2004      (save-excursion
2005        (and (widget-get widget :indent)
2006             (insert-char ?  (widget-get widget :indent)))
2007        (insert (widget-get widget :entry-format)))
2008      ;; Parse % escapes in format.
2009      (while (re-search-forward "%\\(.\\)" nil t)
2010        (let ((escape (aref (match-string 1) 0)))
2011          (replace-match "" t t)
2012          (cond ((eq escape ?%)
2013                 (insert "%"))
2014                ((eq escape ?i)
2015                 (setq insert (apply 'widget-create-child-and-convert
2016                                     widget 'insert-button
2017                                     (widget-get widget :insert-button-args))))
2018                ((eq escape ?d)
2019                 (setq delete (apply 'widget-create-child-and-convert
2020                                     widget 'delete-button
2021                                     (widget-get widget :delete-button-args))))
2022                ((eq escape ?v)
2023                 (if conv
2024                     (setq child (widget-create-child-value
2025                                  widget type value))
2026                   (setq child (widget-create-child widget type))))
2027                (t
2028                 (error "Unknown escape `%c'" escape)))))
2029      (widget-put widget
2030                  :buttons (cons delete
2031                                 (cons insert
2032                                       (widget-get widget :buttons))))
2033      (let ((entry-from (copy-marker (point-min)))
2034            (entry-to (copy-marker (point-max))))
2035        (widget-specify-text entry-from entry-to)
2036        (set-marker-insertion-type entry-from t)
2037        (set-marker-insertion-type entry-to nil)
2038        (widget-put child :entry-from entry-from)
2039        (widget-put child :entry-to entry-to)))
2040     (widget-put insert :widget child)
2041     (widget-put delete :widget child)
2042     child))
2043
2044 ;;; The `group' Widget.
2045
2046 (define-widget 'group 'default
2047   "A widget which group other widgets inside."
2048   :convert-widget 'widget-types-convert-widget
2049   :format "%v"
2050   :value-create 'widget-group-value-create
2051   :value-delete 'widget-children-value-delete
2052   :value-get 'widget-editable-list-value-get
2053   :validate 'widget-editable-list-validate
2054   :match 'widget-group-match
2055   :match-inline 'widget-group-match-inline)
2056
2057 (defun widget-group-value-create (widget)
2058   ;; Create each component.
2059   (let ((args (widget-get widget :args))
2060         (value (widget-get widget :value))
2061         arg answer children)
2062     (while args
2063       (setq arg (car args)
2064             args (cdr args)
2065             answer (widget-match-inline arg value)
2066             value (cdr answer))
2067       (and (eq (preceding-char) ?\n)
2068            (widget-get widget :indent)
2069            (insert-char ?  (widget-get widget :indent)))
2070       (push (cond ((null answer)
2071                    (widget-create-child widget arg))
2072                   ((widget-get arg :inline)
2073                    (widget-create-child-value widget arg  (car answer)))
2074                   (t
2075                    (widget-create-child-value widget arg  (car (car answer)))))
2076             children))
2077     (widget-put widget :children (nreverse children))))
2078
2079 (defun widget-group-match (widget values)
2080   ;; Match if the components match.
2081   (and (listp values)
2082        (let ((match (widget-group-match-inline widget values)))
2083          (and match (null (cdr match))))))
2084
2085 (defun widget-group-match-inline (widget vals)
2086   ;; Match if the components match.
2087   (let ((args (widget-get widget :args))
2088         argument answer found)
2089     (while args
2090       (setq argument (car args)
2091             args (cdr args)
2092             answer (widget-match-inline argument vals))
2093       (if answer
2094           (setq vals (cdr answer)
2095                 found (append found (car answer)))
2096         (setq vals nil
2097               args nil)))
2098     (if answer
2099         (cons found vals)
2100       nil)))
2101
2102 ;;; The `widget-help' Widget.
2103
2104 (define-widget 'widget-help 'push-button
2105   "The widget documentation button."
2106   :format "%[[%t]%] %d"
2107   :help-echo "Toggle display of documentation."
2108   :action 'widget-help-action)
2109
2110 (defun widget-help-action (widget &optional event)
2111   "Toggle documentation for WIDGET."
2112   (let ((old (widget-get widget :doc))
2113         (new (widget-get widget :widget-doc)))
2114     (widget-put widget :doc new)
2115     (widget-put widget :widget-doc old))
2116   (widget-value-set widget (widget-value widget)))
2117
2118 ;;; The Sexp Widgets.
2119
2120 (define-widget 'const 'item
2121   "An immutable sexp."
2122   :format "%t\n%d")
2123
2124 (define-widget 'function-item 'item
2125   "An immutable function name."
2126   :format "%v\n%h"
2127   :documentation-property (lambda (symbol)
2128                             (condition-case nil
2129                                 (documentation symbol t)
2130                               (error nil))))
2131
2132 (define-widget 'variable-item 'item
2133   "An immutable variable name."
2134   :format "%v\n%h"
2135   :documentation-property 'variable-documentation)
2136
2137 (define-widget 'string 'editable-field
2138   "A string"
2139   :tag "String"
2140   :format "%[%t%]: %v")
2141
2142 (define-widget 'regexp 'string
2143   "A regular expression."
2144   ;; Should do validation.
2145   :tag "Regexp")
2146
2147 (define-widget 'file 'string
2148   "A file widget.
2149 It will read a file name from the minibuffer when activated."
2150   :format "%[%t%]: %v"
2151   :tag "File"
2152   :action 'widget-file-action)
2153
2154 (defun widget-file-action (widget &optional event)
2155   ;; Read a file name from the minibuffer.
2156   (let* ((value (widget-value widget))
2157          (dir (file-name-directory value))
2158          (file (file-name-nondirectory value))
2159          (menu-tag (widget-apply widget :menu-tag-get))
2160          (must-match (widget-get widget :must-match))
2161          (answer (read-file-name (concat menu-tag ": (default `" value "') ")
2162                                  dir nil must-match file)))
2163     (widget-value-set widget (abbreviate-file-name answer))
2164     (widget-apply widget :notify widget event)
2165     (widget-setup)))
2166
2167 (define-widget 'directory 'file
2168   "A directory widget.
2169 It will read a directory name from the minibuffer when activated."
2170   :tag "Directory")
2171
2172 (define-widget 'symbol 'string
2173   "A lisp symbol."
2174   :value nil
2175   :tag "Symbol"
2176   :match (lambda (widget value) (symbolp value))
2177   :value-to-internal (lambda (widget value)
2178                        (if (symbolp value)
2179                            (symbol-name value)
2180                          value))
2181   :value-to-external (lambda (widget value)
2182                        (if (stringp value)
2183                            (intern value)
2184                          value)))
2185
2186 (define-widget 'function 'sexp
2187   ;; Should complete on functions.
2188   "A lisp function."
2189   :tag "Function")
2190
2191 (define-widget 'variable 'symbol
2192   ;; Should complete on variables.
2193   "A lisp variable."
2194   :tag "Variable")
2195
2196 (define-widget 'sexp 'string
2197   "An arbitrary lisp expression."
2198   :tag "Lisp expression"
2199   :value nil
2200   :validate 'widget-sexp-validate
2201   :match (lambda (widget value) t)
2202   :value-to-internal 'widget-sexp-value-to-internal
2203   :value-to-external (lambda (widget value) (read value)))
2204
2205 (defun widget-sexp-value-to-internal (widget value)
2206   ;; Use pp for printer representation.
2207   (let ((pp (pp-to-string value)))
2208     (while (string-match "\n\\'" pp)
2209       (setq pp (substring pp 0 -1)))
2210     (if (or (string-match "\n\\'" pp)
2211             (> (length pp) 40))
2212         (concat "\n" pp)
2213       pp)))
2214
2215 (defun widget-sexp-validate (widget)
2216   ;; Valid if we can read the string and there is no junk left after it.
2217   (save-excursion
2218     (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
2219       (erase-buffer)
2220       (insert (widget-apply widget :value-get))
2221       (goto-char (point-min))
2222       (condition-case data
2223           (let ((value (read buffer)))
2224             (if (eobp)
2225                 (if (widget-apply widget :match value)
2226                     nil
2227                   (widget-put widget :error (widget-get widget :type-error))
2228                   widget)
2229               (widget-put widget
2230                           :error (format "Junk at end of expression: %s"
2231                                          (buffer-substring (point)
2232                                                            (point-max))))
2233               widget))
2234         (error (widget-put widget :error (error-message-string data))
2235                widget)))))
2236
2237 (define-widget 'integer 'sexp
2238   "An integer."
2239   :tag "Integer"
2240   :value 0
2241   :type-error "This field should contain an integer"
2242   :value-to-internal (lambda (widget value)
2243                        (if (integerp value)
2244                            (prin1-to-string value)
2245                          value))
2246   :match (lambda (widget value) (integerp value)))
2247
2248 (define-widget 'character 'string
2249   "An character."
2250   :tag "Character"
2251   :value 0
2252   :size 1
2253   :format "%{%t%}: %v\n"
2254   :type-error "This field should contain a character"
2255   :value-to-internal (lambda (widget value)
2256                        (if (integerp value)
2257                            (char-to-string value)
2258                          value))
2259   :value-to-external (lambda (widget value)
2260                        (if (stringp value)
2261                            (aref value 0)
2262                          value))
2263   :match (lambda (widget value) (integerp value)))
2264
2265 (define-widget 'number 'sexp
2266   "A floating point number."
2267   :tag "Number"
2268   :value 0.0
2269   :type-error "This field should contain a number"
2270   :value-to-internal (lambda (widget value)
2271                        (if (numberp value)
2272                            (prin1-to-string value)
2273                          value))
2274   :match (lambda (widget value) (numberp value)))
2275
2276 (define-widget 'list 'group
2277   "A lisp list."
2278   :tag "List"
2279   :format "%{%t%}:\n%v")
2280
2281 (define-widget 'vector 'group
2282   "A lisp vector."
2283   :tag "Vector"
2284   :format "%{%t%}:\n%v"
2285   :match 'widget-vector-match
2286   :value-to-internal (lambda (widget value) (append value nil))
2287   :value-to-external (lambda (widget value) (apply 'vector value)))
2288
2289 (defun widget-vector-match (widget value)
2290   (and (vectorp value)
2291        (widget-group-match widget
2292                            (widget-apply :value-to-internal widget value))))
2293
2294 (define-widget 'cons 'group
2295   "A cons-cell."
2296   :tag "Cons-cell"
2297   :format "%{%t%}:\n%v"
2298   :match 'widget-cons-match
2299   :value-to-internal (lambda (widget value)
2300                        (list (car value) (cdr value)))
2301   :value-to-external (lambda (widget value)
2302                        (cons (nth 0 value) (nth 1 value))))
2303
2304 (defun widget-cons-match (widget value)
2305   (and (consp value)
2306        (widget-group-match widget
2307                            (widget-apply widget :value-to-internal value))))
2308
2309 (define-widget 'choice 'menu-choice
2310   "A union of several sexp types."
2311   :tag "Choice"
2312   :format "%[%t%]: %v")
2313
2314 (define-widget 'radio 'radio-button-choice
2315   "A union of several sexp types."
2316   :tag "Choice"
2317   :format "%{%t%}:\n%v")
2318
2319 (define-widget 'repeat 'editable-list
2320   "A variable length homogeneous list."
2321   :tag "Repeat"
2322   :format "%{%t%}:\n%v%i\n")
2323
2324 (define-widget 'set 'checklist
2325   "A list of members from a fixed set."
2326   :tag "Set"
2327   :format "%{%t%}:\n%v")
2328
2329 (define-widget 'boolean 'toggle
2330   "To be nil or non-nil, that is the question."
2331   :tag "Boolean"
2332   :format "%{%t%}: %[%v%]\n")
2333
2334 ;;; The `color' Widget.
2335
2336 (define-widget 'color-item 'choice-item
2337   "A color name (with sample)."
2338   :format "%v (%{sample%})\n"
2339   :sample-face-get 'widget-color-item-button-face-get)
2340
2341 (defun widget-color-item-button-face-get (widget)
2342   ;; We create a face from the value.
2343   (require 'facemenu)
2344   (condition-case nil
2345       (facemenu-get-face (intern (concat "fg:" (widget-value widget))))
2346     (error 'default)))
2347
2348 (define-widget 'color 'push-button
2349   "Choose a color name (with sample)."
2350   :format "%[%t%]: %v"
2351   :tag "Color"
2352   :value "black"
2353   :value-create 'widget-color-value-create
2354   :value-delete 'widget-children-value-delete
2355   :value-get 'widget-color-value-get
2356   :value-set 'widget-color-value-set
2357   :action 'widget-color-action
2358   :match 'widget-field-match
2359   :tag "Color")
2360
2361 (defvar widget-color-choice-list nil)
2362 ;; Variable holding the possible colors.
2363
2364 (defun widget-color-choice-list ()
2365   (unless widget-color-choice-list
2366     (setq widget-color-choice-list
2367           (mapcar '(lambda (color) (list color))
2368                   (x-defined-colors))))
2369   widget-color-choice-list)
2370
2371 (defun widget-color-value-create (widget)
2372   (let ((child (widget-create-child-and-convert
2373                 widget 'color-item (widget-get widget :value))))
2374     (widget-put widget :children (list child))))
2375
2376 (defun widget-color-value-get (widget)
2377   ;; Pass command to first child.
2378   (widget-apply (car (widget-get widget :children)) :value-get))
2379
2380 (defun widget-color-value-set (widget value)
2381   ;; Pass command to first child.
2382   (widget-apply (car (widget-get widget :children)) :value-set value))
2383
2384 (defvar widget-color-history nil
2385   "History of entered colors")
2386
2387 (defun widget-color-action (widget &optional event)
2388   ;; Prompt for a color.
2389   (let* ((tag (widget-apply widget :menu-tag-get))
2390          (prompt (concat tag ": "))
2391          (answer (cond ((string-match "XEmacs" emacs-version)
2392                         (read-color prompt))
2393                        ((fboundp 'x-defined-colors)
2394                         (completing-read (concat tag ": ")
2395                                          (widget-color-choice-list)
2396                                          nil nil nil 'widget-color-history))
2397                        (t
2398                         (read-string prompt (widget-value widget))))))
2399     (unless (zerop (length answer))
2400       (widget-value-set widget answer)
2401       (widget-apply widget :notify widget event)
2402       (widget-setup))))
2403
2404 ;;; The Help Echo
2405
2406 (defun widget-echo-help-mouse ()
2407   "Display the help message for the widget under the mouse.
2408 Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"
2409   (let* ((pos (mouse-position))
2410          (frame (car pos))
2411          (x (car (cdr pos)))
2412          (y (cdr (cdr pos)))
2413          (win (window-at x y frame))
2414          (where (coordinates-in-window-p (cons x y) win)))
2415     (when (consp where)
2416       (save-window-excursion
2417         (progn ; save-excursion
2418           (select-window win)
2419           (let* ((result (compute-motion (window-start win)
2420                                          '(0 . 0)
2421                                          (window-end win)
2422                                          where
2423                                          (window-width win)
2424                                          (cons (window-hscroll) 0)
2425                                          win)))
2426             (when (and (eq (nth 1 result) x)
2427                        (eq (nth 2 result) y))
2428               (widget-echo-help (nth 0 result))))))))
2429   (unless track-mouse
2430     (setq track-mouse t)
2431     (add-hook 'post-command-hook 'widget-stop-mouse-tracking)))
2432
2433 (defun widget-stop-mouse-tracking (&rest args)
2434   "Stop the mouse tracking done while idle."
2435   (remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
2436   (setq track-mouse nil))
2437
2438 (defun widget-at (pos)
2439   "The button or field at POS."
2440   (or (get-text-property pos 'button)
2441       (get-text-property pos 'field)))
2442
2443 (defun widget-echo-help (pos)
2444   "Display the help echo for widget at POS."
2445   (let* ((widget (widget-at pos))
2446          (help-echo (and widget (widget-get widget :help-echo))))
2447     (cond ((stringp help-echo)
2448            (message "%s" help-echo))
2449           ((and (symbolp help-echo) (fboundp help-echo)
2450                 (stringp (setq help-echo (funcall help-echo widget))))
2451            (message "%s" help-echo)))))
2452
2453 ;;; The End:
2454
2455 (provide 'wid-edit)
2456
2457 ;; wid-edit.el ends here