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