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 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: extensions
   7 ;; Version: 1.15
   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     (when (fboundp 'copy-face)
  53       (copy-face 'default 'widget-documentation-face)
  54       (copy-face 'bold 'widget-button-face)
  55       (copy-face 'italic 'widget-field-face))
  56     (defvar widget-mouse-face 'highlight)
  57     (defvar widget-menu-max-size 40)))
  58
  59 ;;; Compatibility.
  60
  61 (or (fboundp 'event-point)
  62     ;; XEmacs function missing in Emacs.
  63     (defun event-point (event)
  64       "Return the character position of the given mouse-motion, button-press,
  65 or button-release event.  If the event did not occur over a window, or did
  66 not occur over text, then this returns nil.  Otherwise, it returns an index
  67 into the buffer visible in the event's window."
  68       (posn-point (event-start event))))
  69
  70 ;;; Customization.
  71
  72 (defgroup widgets nil
  73   "Customization support for the Widget Library."
  74   :link '(custom-manual "(widget)Top")
  75   :link '(url-link :tag "Development Page"
  76                    "http://www.dina.kvl.dk/~abraham/custom/")
  77   :prefix "widget-"
  78   :group 'emacs)
  79
  80 (defface widget-documentation-face '((((class color)
  81                                        (background dark))
  82                                       (:foreground "lime green"))
  83                                      (((class color)
  84                                        (background light))
  85                                       (:foreground "dark green"))
  86                                      (t nil))
  87   "Face used for documentation text."
  88   :group 'widgets)
  89
  90 (defface widget-button-face '((t (:bold t)))
  91   "Face used for widget buttons."
  92   :group 'widgets)
  93
  94 (defcustom widget-mouse-face 'highlight
  95   "Face used for widget buttons when the mouse is above them."
  96   :type 'face
  97   :group 'widgets)
  98
  99 (defface widget-field-face '((((class grayscale color)
 100                                (background light))
 101                               (:background "light gray"))
 102                              (((class grayscale color)
 103                                (background dark))
 104                               (:background "dark gray"))
 105                              (t
 106                               (:italic t)))
 107   "Face used for editable fields."
 108   :group 'widgets)
 109
 110 (defcustom widget-menu-max-size 40
 111   "Largest number of items allowed in a popup-menu.
 112 Larger menus are read through the minibuffer."
 113   :group 'widgets
 114   :type 'integer)
 115
 116 ;;; Utility functions.
 117 ;;
 118 ;; These are not really widget specific.
 119
 120 (defun widget-plist-member (plist prop)
 121   ;; Return non-nil if PLIST has the property PROP.
 122   ;; PLIST is a property list, which is a list of the form
 123   ;; (PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol.
 124   ;; Unlike `plist-get', this allows you to distinguish between a missing
 125   ;; property and a property with the value nil.
 126   ;; The value is actually the tail of PLIST whose car is PROP.
 127   (while (and plist (not (eq (car plist) prop)))
 128     (setq plist (cdr (cdr plist))))
 129   plist)
 130
 131 (defun widget-princ-to-string (object)
 132   ;; Return string representation of OBJECT, any Lisp object.
 133   ;; No quoting characters are used; no delimiters are printed around
 134   ;; the contents of strings.
 135   (save-excursion
 136     (set-buffer (get-buffer-create " *widget-tmp*"))
 137     (erase-buffer)
 138     (let ((standard-output (current-buffer)))
 139       (princ object))
 140     (buffer-string)))
 141
 142 (defun widget-clear-undo ()
 143   "Clear all undo information."
 144   (buffer-disable-undo (current-buffer))
 145   (buffer-enable-undo))
 146
 147 (defun widget-choose (title items &optional event)
 148   "Choose an item from a list.
 149
 150 First argument TITLE is the name of the list.
 151 Second argument ITEMS is an alist (NAME . VALUE).
 152 Optional third argument EVENT is an input event.
 153
 154 The user is asked to choose between each NAME from the items alist,
 155 and the VALUE of the chosen element will be returned.  If EVENT is a
 156 mouse event, and the number of elements in items is less than
 157 `widget-menu-max-size', a popup menu will be used, otherwise the
 158 minibuffer."
 159   (cond ((and (< (length items) widget-menu-max-size)
 160               event (fboundp 'x-popup-menu) window-system)
 161          ;; We are in Emacs-19, pressed by the mouse
 162          (x-popup-menu event
 163                        (list title (cons "" items))))
 164         ((and (< (length items) widget-menu-max-size)
 165               event (fboundp 'popup-menu) window-system)
 166          ;; We are in XEmacs, pressed by the mouse
 167          (let ((val (get-popup-menu-response
 168                      (cons ""
 169                            (mapcar
 170                             (function
 171                              (lambda (x)
 172                                (vector (car x) (list (car x)) t)))
 173                             items)))))
 174            (setq val (and val
 175                           (listp (event-object val))
 176                           (stringp (car-safe (event-object val)))
 177                           (car (event-object val))))
 178            (cdr (assoc val items))))
 179         (t
 180          (cdr (assoc (completing-read (concat title ": ")
 181                                       items nil t)
 182                      items)))))
 183
 184 ;;; Widget text specifications.
 185 ;;
 186 ;; These functions are for specifying text properties.
 187
 188 (defun widget-specify-none (from to)
 189   ;; Clear all text properties between FROM and TO.
 190   (set-text-properties from to nil))
 191
 192 (defun widget-specify-text (from to)
 193   ;; Default properties.
 194   (add-text-properties from to (list 'read-only t
 195                                      'front-sticky t
 196                                      'start-open t
 197                                      'end-open t
 198                                      'rear-nonsticky nil)))
 199
 200 (defun widget-specify-field (widget from to)
 201   ;; Specify editable button for WIDGET between FROM and TO.
 202   (widget-specify-field-update widget from to)
 203
 204   ;; Make it possible to edit the front end of the field.
 205   (add-text-properties (1- from) from (list 'rear-nonsticky t
 206                                             'end-open t
 207                                             'invisible t))
 208   (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
 209             (widget-get widget :hide-front-space))
 210     ;; WARNING: This is going to lose horrible if the character just
 211     ;; before the field can be modified (e.g. if it belongs to a
 212     ;; choice widget).  We try to compensate by checking the format
 213     ;; string, and hope the user hasn't changed the :create method.
 214     (widget-make-intangible (- from 2) from 'end-open))
 215
 216   ;; Make it possible to edit back end of the field.
 217   (add-text-properties to (1+ to) (list 'front-sticky nil
 218                                         'read-only t
 219                                         'start-open t))
 220
 221   (cond ((widget-get widget :size)
 222          (put-text-property to (1+ to) 'invisible t)
 223          (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
 224                    (widget-get widget :hide-rear-space))
 225            ;; WARNING: This is going to lose horrible if the character just
 226            ;; after the field can be modified (e.g. if it belongs to a
 227            ;; choice widget).  We try to compensate by checking the format
 228            ;; string, and hope the user hasn't changed the :create method.
 229            (widget-make-intangible to (+ to 2) 'start-open)))
 230         ((string-match "XEmacs" emacs-version)
 231          ;; XEmacs does not allow you to insert before a read-only
 232          ;; character, even if it is start.open.
 233          ;; XEmacs does allow you to delete an read-only extent, so
 234          ;; making the terminating newline read only doesn't help.
 235          ;; I tried putting an invisible intangible read-only space
 236          ;; before the newline, which gave really weird effects.
 237          ;; So for now, we just have trust the user not to delete the
 238          ;; newline.
 239          (put-text-property to (1+ to) 'read-only nil))))
 240
 241 (defun widget-specify-field-update (widget from to)
 242   ;; Specify editable button for WIDGET between FROM and TO.
 243   (let ((map (widget-get widget :keymap))
 244         (face (or (widget-get widget :value-face)
 245                   'widget-field-face)))
 246     (set-text-properties from to (list 'field widget
 247                                        'read-only nil
 248                                        'keymap map
 249                                        'local-map map
 250                                        'face face))
 251     (unless (widget-get widget :size)
 252       (put-text-property to (1+ to) 'face face))))
 253
 254 (defun widget-specify-button (widget from to)
 255   ;; Specify button for WIDGET between FROM and TO.
 256   (let ((face (widget-apply widget :button-face-get)))
 257     (add-text-properties from to (list 'button widget
 258                                        'mouse-face widget-mouse-face
 259                                        'start-open t
 260                                        'end-open t
 261                                        'face face))))
 262
 263 (defun widget-specify-doc (widget from to)
 264   ;; Specify documentation for WIDGET between FROM and TO.
 265   (add-text-properties from to (list 'widget-doc widget
 266                                      'face 'widget-documentation-face)))
 267
 268 (defmacro widget-specify-insert (&rest form)
 269   ;; Execute FORM without inheriting any text properties.
 270   `(save-restriction
 271      (let ((inhibit-read-only t)
 272            result
 273            after-change-functions)
 274        (insert "<>")
 275        (narrow-to-region (- (point) 2) (point))
 276        (widget-specify-none (point-min) (point-max))
 277        (goto-char (1+ (point-min)))
 278        (setq result (progn ,@form))
 279        (delete-region (point-min) (1+ (point-min)))
 280        (delete-region (1- (point-max)) (point-max))
 281        (goto-char (point-max))
 282        result)))
 283
 284 ;;; Widget Properties.
 285
 286 (defun widget-put (widget property value)
 287   "In WIDGET set PROPERTY to VALUE.
 288 The value can later be retrived with `widget-get'."
 289   (setcdr widget (plist-put (cdr widget) property value)))
 290
 291 (defun widget-get (widget property)
 292   "In WIDGET, get the value of PROPERTY.
 293 The value could either be specified when the widget was created, or
 294 later with `widget-put'."
 295   (cond ((widget-plist-member (cdr widget) property)
 296          (plist-get (cdr widget) property))
 297         ((car widget)
 298          (widget-get (get (car widget) 'widget-type) property))
 299         (t nil)))
 300
 301 (defun widget-member (widget property)
 302   "Non-nil iff there is a definition in WIDGET for PROPERTY."
 303   (cond ((widget-plist-member (cdr widget) property)
 304          t)
 305         ((car widget)
 306          (widget-member (get (car widget) 'widget-type) property))
 307         (t nil)))
 308
 309 (defun widget-apply (widget property &rest args)
 310   "Apply the value of WIDGET's PROPERTY to the widget itself.
 311 ARGS are passed as extra argments to the function."
 312   (apply (widget-get widget property) widget args))
 313
 314 (defun widget-value (widget)
 315   "Extract the current value of WIDGET."
 316   (widget-apply widget
 317                 :value-to-external (widget-apply widget :value-get)))
 318
 319 (defun widget-value-set (widget value)
 320   "Set the current value of WIDGET to VALUE."
 321   (widget-apply widget
 322                 :value-set (widget-apply widget
 323                                          :value-to-internal value)))
 324
 325 (defun widget-match-inline (widget vals)
 326   ;; In WIDGET, match the start of VALS.
 327   (cond ((widget-get widget :inline)
 328          (widget-apply widget :match-inline vals))
 329         ((and vals
 330               (widget-apply widget :match (car vals)))
 331          (cons (list (car vals)) (cdr vals)))
 332         (t nil)))
 333
 334 ;;; Creating Widgets.
 335
 336 ;;;###autoload
 337 (defun widget-create (type &rest args)
 338   "Create widget of TYPE.
 339 The optional ARGS are additional keyword arguments."
 340   (let ((widget (apply 'widget-convert type args)))
 341     (widget-apply widget :create)
 342     widget))
 343
 344 (defun widget-create-child-and-convert (parent type &rest args)
 345   "As part of the widget PARENT, create a child widget TYPE.
 346 The child is converted, using the keyword arguments ARGS."
 347   (let ((widget (apply 'widget-convert type args)))
 348     (widget-put widget :parent parent)
 349     (unless (widget-get widget :indent)
 350       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 351                                     (or (widget-get widget :extra-offset) 0)
 352                                     (widget-get parent :offset))))
 353     (widget-apply widget :create)
 354     widget))
 355
 356 (defun widget-create-child (parent type)
 357   "Create widget of TYPE."
 358   (let ((widget (copy-list type)))
 359     (widget-put widget :parent parent)
 360     (unless (widget-get widget :indent)
 361       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 362                                     (or (widget-get widget :extra-offset) 0)
 363                                     (widget-get parent :offset))))
 364     (widget-apply widget :create)
 365     widget))
 366
 367 (defun widget-create-child-value (parent type value)
 368   "Create widget of TYPE with value VALUE."
 369   (let ((widget (copy-list type)))
 370     (widget-put widget :value (widget-apply widget :value-to-internal value))
 371     (widget-put widget :parent parent)
 372     (unless (widget-get widget :indent)
 373       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 374                                     (or (widget-get widget :extra-offset) 0)
 375                                     (widget-get parent :offset))))
 376     (widget-apply widget :create)
 377     widget))
 378
 379 ;;;###autoload
 380 (defun widget-delete (widget)
 381   "Delete WIDGET."
 382   (widget-apply widget :delete))
 383
 384 (defun widget-convert (type &rest args)
 385   "Convert TYPE to a widget without inserting it in the buffer.
 386 The optional ARGS are additional keyword arguments."
 387   ;; Don't touch the type.
 388   (let* ((widget (if (symbolp type)
 389                      (list type)
 390                    (copy-list type)))
 391          (current widget)
 392          (keys args))
 393     ;; First set the :args keyword.
 394     (while (cdr current)                ;Look in the type.
 395       (let ((next (car (cdr current))))
 396         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 397             (setq current (cdr (cdr current)))
 398           (setcdr current (list :args (cdr current)))
 399           (setq current nil))))
 400     (while args                         ;Look in the args.
 401       (let ((next (nth 0 args)))
 402         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 403             (setq args (nthcdr 2 args))
 404           (widget-put widget :args args)
 405           (setq args nil))))
 406     ;; Then Convert the widget.
 407     (setq type widget)
 408     (while type
 409       (let ((convert-widget (plist-get (cdr type) :convert-widget)))
 410         (if convert-widget
 411             (setq widget (funcall convert-widget widget))))
 412       (setq type (get (car type) 'widget-type)))
 413     ;; Finally set the keyword args.
 414     (while keys
 415       (let ((next (nth 0 keys)))
 416         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 417             (progn
 418               (widget-put widget next (nth 1 keys))
 419               (setq keys (nthcdr 2 keys)))
 420           (setq keys nil))))
 421     ;; Convert the :value to internal format.
 422     (if (widget-member widget :value)
 423         (let ((value (widget-get widget :value)))
 424           (widget-put widget
 425                       :value (widget-apply widget :value-to-internal value))))
 426     ;; Return the newly create widget.
 427     widget))
 428
 429 (defun widget-insert (&rest args)
 430   "Call `insert' with ARGS and make the text read only."
 431   (let ((inhibit-read-only t)
 432         after-change-functions
 433         (from (point)))
 434     (apply 'insert args)
 435     (widget-specify-text from (point))))
 436
 437 ;;; Keymap and Comands.
 438
 439 (defvar widget-keymap nil
 440   "Keymap containing useful binding for buffers containing widgets.
 441 Recommended as a parent keymap for modes using widgets.")
 442
 443 (if widget-keymap
 444     ()
 445   (setq widget-keymap (make-sparse-keymap))
 446   (set-keymap-parent widget-keymap global-map)
 447   (define-key widget-keymap "\t" 'widget-forward)
 448   (define-key widget-keymap "\M-\t" 'widget-backward)
 449   (define-key widget-keymap [(shift tab)] 'widget-backward)
 450   (define-key widget-keymap [(shift tab)] 'widget-backward)
 451   (define-key widget-keymap [backtab] 'widget-backward)
 452   (if (string-match "XEmacs" (emacs-version))
 453       (define-key widget-keymap [button2] 'widget-button-click)
 454     (define-key widget-keymap [menu-bar] 'nil)
 455     (define-key widget-keymap [mouse-2] 'widget-button-click))
 456   (define-key widget-keymap "\C-m" 'widget-button-press))
 457
 458 (defvar widget-global-map global-map
 459   "Keymap used for events the widget does not handle themselves.")
 460 (make-variable-buffer-local 'widget-global-map)
 461
 462 (defun widget-button-click (event)
 463   "Activate button below mouse pointer."
 464   (interactive "@e")
 465   (widget-button-press (event-point event) event))
 466
 467 (defun widget-button-press (pos &optional event)
 468   "Activate button at POS."
 469   (interactive "@d")
 470   (let* ((button (get-text-property pos 'button)))
 471     (if button
 472         (widget-apply button :action event)
 473       (call-interactively
 474        (lookup-key widget-global-map (this-command-keys))))))
 475
 476 (defun widget-move (arg)
 477   "Move point to the ARG next field or button.
 478 ARG may be negative to move backward."
 479   (while (> arg 0)
 480     (setq arg (1- arg))
 481     (let ((next (cond ((get-text-property (point) 'button)
 482                        (next-single-property-change (point) 'button))
 483                       ((get-text-property (point) 'field)
 484                        (next-single-property-change (point) 'field))
 485                       (t
 486                        (point)))))
 487       (if (null next)                   ; Widget extends to end. of buffer
 488           (setq next (point-min)))
 489       (let ((button (next-single-property-change next 'button))
 490             (field (next-single-property-change next 'field)))
 491         (cond ((or (get-text-property next 'button)
 492                    (get-text-property next 'field))
 493                (goto-char next))
 494               ((and button field)
 495                (goto-char (min button field)))
 496               (button (goto-char button))
 497               (field (goto-char field))
 498               (t
 499                (let ((button (next-single-property-change (point-min) 'button))
 500                      (field (next-single-property-change (point-min) 'field)))
 501                  (cond ((and button field) (goto-char (min button field)))
 502                        (button (goto-char button))
 503                        (field (goto-char field))
 504                        (t
 505                         (error "No buttons or fields found")))))))))
 506   (while (< arg 0)
 507     (if (= (point-min) (point))
 508         (forward-char 1))
 509     (setq arg (1+ arg))
 510     (let ((previous (cond ((get-text-property (1- (point)) 'button)
 511                            (previous-single-property-change (point) 'button))
 512                           ((get-text-property (1- (point)) 'field)
 513                            (previous-single-property-change (point) 'field))
 514                           (t
 515                            (point)))))
 516       (if (null previous)               ; Widget extends to beg. of buffer
 517           (setq previous (point-max)))
 518       (let ((button (previous-single-property-change previous 'button))
 519             (field (previous-single-property-change previous 'field)))
 520         (cond ((and button field)
 521                (goto-char (max button field)))
 522               (button (goto-char button))
 523               (field (goto-char field))
 524               (t
 525                (let ((button (previous-single-property-change
 526                               (point-max) 'button))
 527                      (field (previous-single-property-change
 528                              (point-max) 'field)))
 529                  (cond ((and button field) (goto-char (max button field)))
 530                        (button (goto-char button))
 531                        (field (goto-char field))
 532                        (t
 533                         (error "No buttons or fields found"))))))))
 534     (let ((button (previous-single-property-change (point) 'button))
 535           (field (previous-single-property-change (point) 'field)))
 536       (cond ((and button field)
 537              (goto-char (max button field)))
 538             (button (goto-char button))
 539             (field (goto-char field)))))
 540   (widget-echo-help (point))
 541   (run-hooks 'widget-move-hook))
 542
 543 (defun widget-forward (arg)
 544   "Move point to the next field or button.
 545 With optional ARG, move across that many fields."
 546   (interactive "p")
 547   (run-hooks 'widget-forward-hook)
 548   (widget-move arg))
 549
 550 (defun widget-backward (arg)
 551   "Move point to the previous field or button.
 552 With optional ARG, move across that many fields."
 553   (interactive "p")
 554   (run-hooks 'widget-backward-hook)
 555   (widget-move (- arg)))
 556
 557 ;;; Setting up the buffer.
 558
 559 (defvar widget-field-new nil)
 560 ;; List of all newly created editable fields in the buffer.
 561 (make-variable-buffer-local 'widget-field-new)
 562
 563 (defvar widget-field-list nil)
 564 ;; List of all editable fields in the buffer.
 565 (make-variable-buffer-local 'widget-field-list)
 566
 567 (defun widget-setup ()
 568   "Setup current buffer so editing string widgets works."
 569   (let ((inhibit-read-only t)
 570         (after-change-functions nil)
 571         field)
 572     (while widget-field-new
 573       (setq field (car widget-field-new)
 574             widget-field-new (cdr widget-field-new)
 575             widget-field-list (cons field widget-field-list))
 576       (let ((from (widget-get field :value-from))
 577             (to (widget-get field :value-to)))
 578         (widget-specify-field field from to)
 579         (move-marker from (1- from))
 580         (move-marker to (1+ to)))))
 581   (widget-clear-undo)
 582   ;; We need to maintain text properties and size of the editing fields.
 583   (make-local-variable 'after-change-functions)
 584   (if widget-field-list
 585       (setq after-change-functions '(widget-after-change))
 586     (setq after-change-functions nil)))
 587
 588 (defvar widget-field-last nil)
 589 ;; Last field containing point.
 590 (make-variable-buffer-local 'widget-field-last)
 591
 592 (defvar widget-field-was nil)
 593 ;; The widget data before the change.
 594 (make-variable-buffer-local 'widget-field-was)
 595
 596 (defun widget-field-find (pos)
 597   ;; Find widget whose editing field is located at POS.
 598   ;; Return nil if POS is not inside and editing field.
 599   ;;
 600   ;; This is only used in `widget-field-modified', since ordinarily
 601   ;; you would just test the field property.
 602   (let ((fields widget-field-list)
 603         field found)
 604     (while fields
 605       (setq field (car fields)
 606             fields (cdr fields))
 607       (let ((from (widget-get field :value-from))
 608             (to (widget-get field :value-to)))
 609         (if (and from to (< from pos) (> to  pos))
 610             (setq fields nil
 611                   found field))))
 612     found))
 613
 614 (defun widget-after-change (from to old)
 615   ;; Adjust field size and text properties.
 616   (condition-case nil
 617       (let ((field (widget-field-find from))
 618             (inhibit-read-only t))
 619         (cond ((null field))
 620               ((not (eq field (widget-field-find to)))
 621                (debug)
 622                (message "Error: `widget-after-change' called on two fields"))
 623               (t
 624                (let ((size (widget-get field :size)))
 625                  (if size
 626                      (let ((begin (1+ (widget-get field :value-from)))
 627                            (end (1- (widget-get field :value-to))))
 628                        (widget-specify-field-update field begin end)
 629                        (cond ((< (- end begin) size)
 630                               ;; Field too small.
 631                               (save-excursion
 632                                 (goto-char end)
 633                                 (insert-char ?\  (- (+ begin size) end))
 634                                 (widget-specify-field-update field
 635                                                              begin
 636                                                              (+ begin size))))
 637                              ((> (- end begin) size)
 638                               ;; Field too large and
 639                               (if (or (< (point) (+ begin size))
 640                                       (> (point) end))
 641                                   ;; Point is outside extra space.
 642                                   (setq begin (+ begin size))
 643                                 ;; Point is within the extra space.
 644                                 (setq begin (point)))
 645                               (save-excursion
 646                                 (goto-char end)
 647                                 (while (and (eq (preceding-char) ?\ )
 648                                             (> (point) begin))
 649                                   (delete-backward-char 1))))))
 650                    (widget-specify-field-update field from to)))
 651                (widget-apply field :notify field))))
 652     (error (debug))))
 653
 654 ;;; Widget Functions
 655 ;;
 656 ;; These functions are used in the definition of multiple widgets.
 657
 658 (defun widget-children-value-delete (widget)
 659   "Delete all :children and :buttons in WIDGET."
 660   (mapcar 'widget-delete (widget-get widget :children))
 661   (widget-put widget :children nil)
 662   (mapcar 'widget-delete (widget-get widget :buttons))
 663   (widget-put widget :buttons nil))
 664
 665 (defun widget-types-convert-widget (widget)
 666   "Convert :args as widget types in WIDGET."
 667   (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
 668   widget)
 669
 670 ;;; The `default' Widget.
 671
 672 (define-widget 'default nil
 673   "Basic widget other widgets are derived from."
 674   :value-to-internal (lambda (widget value) value)
 675   :value-to-external (lambda (widget value) value)
 676   :create 'widget-default-create
 677   :indent nil
 678   :offset 0
 679   :format-handler 'widget-default-format-handler
 680   :button-face-get 'widget-default-button-face-get
 681   :delete 'widget-default-delete
 682   :value-set 'widget-default-value-set
 683   :value-inline 'widget-default-value-inline
 684   :menu-tag-get 'widget-default-menu-tag-get
 685   :validate (lambda (widget) nil)
 686   :action 'widget-default-action
 687   :notify 'widget-default-notify)
 688
 689 (defun widget-default-create (widget)
 690   "Create WIDGET at point in the current buffer."
 691   (widget-specify-insert
 692    (let ((from (point))
 693          (tag (widget-get widget :tag))
 694          (doc (widget-get widget :doc))
 695          button-begin button-end
 696          doc-begin doc-end
 697          value-pos)
 698      (insert (widget-get widget :format))
 699      (goto-char from)
 700      ;; Parse % escapes in format.
 701      (while (re-search-forward "%\\(.\\)" nil t)
 702        (let ((escape (aref (match-string 1) 0)))
 703          (replace-match "" t t)
 704          (cond ((eq escape ?%)
 705                 (insert "%"))
 706                ((eq escape ?\[)
 707                 (setq button-begin (point)))
 708                ((eq escape ?\])
 709                 (setq button-end (point)))
 710                ((eq escape ?n)
 711                 (when (widget-get widget :indent)
 712                   (insert "\n")
 713                   (insert-char ?  (widget-get widget :indent))))
 714                ((eq escape ?t)
 715                 (if tag
 716                     (insert tag)
 717                   (let ((standard-output (current-buffer)))
 718                     (princ (widget-get widget :value)))))
 719                ((eq escape ?d)
 720                 (when doc
 721                   (setq doc-begin (point))
 722                   (insert doc)
 723                   (while (eq (preceding-char) ?\n)
 724                     (delete-backward-char 1))
 725                   (insert "\n")
 726                   (setq doc-end (point))))
 727                ((eq escape ?v)
 728                 (if (and button-begin (not button-end))
 729                     (widget-apply widget :value-create)
 730                   (setq value-pos (point))))
 731                (t
 732                 (widget-apply widget :format-handler escape)))))
 733      ;; Specify button and doc, and insert value.
 734      (and button-begin button-end
 735           (widget-specify-button widget button-begin button-end))
 736      (and doc-begin doc-end
 737           (widget-specify-doc widget doc-begin doc-end))
 738      (when value-pos
 739        (goto-char value-pos)
 740        (widget-apply widget :value-create)))
 741    (let ((from (copy-marker (point-min)))
 742          (to (copy-marker (point-max))))
 743      (widget-specify-text from to)
 744      (set-marker-insertion-type from t)
 745      (set-marker-insertion-type to nil)
 746      (widget-put widget :from from)
 747      (widget-put widget :to to))))
 748
 749 (defun widget-default-format-handler (widget escape)
 750   ;; We recognize the %h escape by default.
 751   (let* ((buttons (widget-get widget :buttons))
 752          (doc-property (widget-get widget :documentation-property))
 753          (doc-try (cond ((widget-get widget :doc))
 754                         ((symbolp doc-property)
 755                          (documentation-property (widget-get widget :value)
 756                                                  doc-property))
 757                         (t
 758                          (funcall doc-property (widget-get widget :value)))))
 759          (doc-text (and (stringp doc-try)
 760                         (> (length doc-try) 1)
 761                         doc-try)))
 762     (cond ((eq escape ?h)
 763            (when doc-text
 764              (and (eq (preceding-char) ?\n)
 765                   (widget-get widget :indent)
 766                   (insert-char ?  (widget-get widget :indent)))
 767              ;; The `*' in the beginning is redundant.
 768              (when (eq (aref doc-text  0) ?*)
 769                (setq doc-text (substring doc-text 1)))
 770              ;; Get rid of trailing newlines.
 771              (when (string-match "\n+\\'" doc-text)
 772                (setq doc-text (substring doc-text 0 (match-beginning 0))))
 773              (push (if (string-match "\n." doc-text)
 774                        ;; Allow multiline doc to be hiden.
 775                        (widget-create-child-and-convert
 776                         widget 'widget-help
 777                         :doc (progn
 778                                (string-match "\\`.*" doc-text)
 779                                (match-string 0 doc-text))
 780                         :widget-doc doc-text
 781                         "?")
 782                      ;; A single line is just inserted.
 783                      (widget-create-child-and-convert
 784                       widget 'item :format "%d" :doc doc-text nil))
 785                    buttons)))
 786           (t
 787            (error "Unknown escape `%c'" escape)))
 788     (widget-put widget :buttons buttons)))
 789
 790 (defun widget-default-button-face-get (widget)
 791   ;; Use :button-face or widget-button-face
 792   (or (widget-get widget :button-face) 'widget-button-face))
 793
 794 (defun widget-default-delete (widget)
 795   ;; Remove widget from the buffer.