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

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