Mercurial > hg > xemacs-beta

comparison lisp/custom/wid-edit.el @ 108:360340f9fd5f r20-1b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b6
author cvs
date Mon, 13 Aug 2007 09:18:39 +0200
parents ec9a17fef872
children e04119814345
comparison
equal deleted inserted replaced
107:523141596bda 108:360340f9fd5f
2 ;; 2 ;;
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
4 ;; 4 ;;
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Keywords: extensions 6 ;; Keywords: extensions
7 ;; Version: 1.50 7 ;; Version: 1.59
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
9 9
10 ;;; Commentary: 10 ;;; Commentary:
11 ;; 11 ;;
12 ;; See `widget.el'. 12 ;; See `widget.el'.
13 13
14 ;;; Code: 14 ;;; Code:
15 15
16 (require 'widget) 16 (require 'widget)
17 (require 'cl) 17
18 (autoload 'pp-to-string "pp") 18 (eval-and-compile
19 (autoload 'Info-goto-node "info") 19 (require 'cl))
20 20
21 (if (string-match "XEmacs" emacs-version) 21 ;;; Compatibility.
22 ;; XEmacs spell `intangible' as `atomic'. 22
23 (defun widget-make-intangible (from to side) 23 (eval-and-compile
24 "Make text between FROM and TO atomic with regard to movement. 24 (autoload 'pp-to-string "pp")
25 (autoload 'Info-goto-node "info")
26
27 (if (string-match "XEmacs" emacs-version)
28 ;; XEmacs spell `intangible' as `atomic'.
29 (defun widget-make-intangible (from to side)
30 "Make text between FROM and TO atomic with regard to movement.
25 Third argument should be `start-open' if it should be sticky to the rear, 31 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." 32 and `end-open' if it should sticky to the front."
27 (require 'atomic-extents) 33 (require 'atomic-extents)
28 (let ((ext (make-extent from to))) 34 (let ((ext (make-extent from to)))
29 ;; XEmacs doesn't understant different kinds of read-only, so 35 ;; XEmacs doesn't understant different kinds of read-only, so
30 ;; we have to use extents instead. 36 ;; we have to use extents instead.
31 (put-text-property from to 'read-only nil) 37 (put-text-property from to 'read-only nil)
32 (set-extent-property ext 'read-only t) 38 (set-extent-property ext 'read-only t)
33 (set-extent-property ext 'start-open nil) 39 (set-extent-property ext 'start-open nil)
34 (set-extent-property ext 'end-open nil) 40 (set-extent-property ext 'end-open nil)
35 (set-extent-property ext side t) 41 (set-extent-property ext side t)
36 (set-extent-property ext 'atomic t))) 42 (set-extent-property ext 'atomic t)))
37 (defun widget-make-intangible (from to size) 43 (defun widget-make-intangible (from to size)
38 "Make text between FROM and TO intangible." 44 "Make text between FROM and TO intangible."
39 (put-text-property from to 'intangible 'front))) 45 (put-text-property from to 'intangible 'front)))
40 46
41 ;; The following should go away when bundled with Emacs. 47 ;; The following should go away when bundled with Emacs.
42 (eval-and-compile
43 (condition-case () 48 (condition-case ()
44 (require 'custom) 49 (require 'custom)
45 (error nil)) 50 (error nil))
46 51
47 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) 52 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
52 (defmacro defface (&rest args) nil) 57 (defmacro defface (&rest args) nil)
53 (define-widget-keywords :prefix :tag :load :link :options :type :group) 58 (define-widget-keywords :prefix :tag :load :link :options :type :group)
54 (when (fboundp 'copy-face) 59 (when (fboundp 'copy-face)
55 (copy-face 'default 'widget-documentation-face) 60 (copy-face 'default 'widget-documentation-face)
56 (copy-face 'bold 'widget-button-face) 61 (copy-face 'bold 'widget-button-face)
57 (copy-face 'italic 'widget-field-face)))) 62 (copy-face 'italic 'widget-field-face)))
58 63
59 ;;; Compatibility. 64 (unless (fboundp 'event-point)
60 65 ;; XEmacs function missing in Emacs.
61 (unless (fboundp 'event-point) 66 (defun event-point (event)
62 ;; XEmacs function missing in Emacs. 67 "Return the character position of the given mouse-motion, button-press,
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 68 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 69 not occur over text, then this returns nil. Otherwise, it returns an index
67 into the buffer visible in the event's window." 70 into the buffer visible in the event's window."
68 (posn-point (event-start event)))) 71 (posn-point (event-start event))))
69 72
70 (unless (fboundp 'error-message-string) 73 (unless (fboundp 'error-message-string)
71 ;; Emacs function missing in XEmacs. 74 ;; Emacs function missing in XEmacs.
72 (defun error-message-string (obj) 75 (defun error-message-string (obj)
73 "Convert an error value to an error message." 76 "Convert an error value to an error message."
74 (let ((buf (get-buffer-create " *error-message*"))) 77 (let ((buf (get-buffer-create " *error-message*")))
75 (erase-buffer buf) 78 (erase-buffer buf)
76 (display-error obj buf) 79 (display-error obj buf)
77 (buffer-string buf)))) 80 (buffer-string buf)))))
78 81
79 ;;; Customization. 82 ;;; Customization.
80 83
81 (defgroup widgets nil 84 (defgroup widgets nil
82 "Customization support for the Widget Library." 85 "Customization support for the Widget Library."
186 (listp (event-object val)) 189 (listp (event-object val))
187 (stringp (car-safe (event-object val))) 190 (stringp (car-safe (event-object val)))
188 (car (event-object val)))) 191 (car (event-object val))))
189 (cdr (assoc val items)))) 192 (cdr (assoc val items))))
190 (t 193 (t
191 (cdr (assoc (completing-read (concat title ": ") 194 (let ((val (completing-read (concat title ": ") items nil t)))
192 items nil t) 195 (if (stringp val)
193 items))))) 196 (let ((try (try-completion val items)))
197 (when (stringp try)
198 (setq val try))
199 (cdr (assoc val items)))
200 nil)))))
194 201
195 (defun widget-get-sibling (widget) 202 (defun widget-get-sibling (widget)
196 "Get the item WIDGET is assumed to toggle. 203 "Get the item WIDGET is assumed to toggle.
197 This is only meaningful for radio buttons or checkboxes in a list." 204 This is only meaningful for radio buttons or checkboxes in a list."
198 (let* ((parent (widget-get widget :parent)) 205 (let* ((parent (widget-get widget :parent))
226 ;; Specify editable button for WIDGET between FROM and TO. 233 ;; Specify editable button for WIDGET between FROM and TO.
227 (widget-specify-field-update widget from to) 234 (widget-specify-field-update widget from to)
228 235
229 ;; Make it possible to edit the front end of the field. 236 ;; Make it possible to edit the front end of the field.
230 (add-text-properties (1- from) from (list 'rear-nonsticky t 237 (add-text-properties (1- from) from (list 'rear-nonsticky t
231 'end-open t 238 'end-open t
232 'invisible t)) 239 'invisible t))
233 (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format)) 240 (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
234 (widget-get widget :hide-front-space)) 241 (widget-get widget :hide-front-space))
235 ;; WARNING: This is going to lose horrible if the character just 242 ;; WARNING: This is going to lose horrible if the character just
236 ;; before the field can be modified (e.g. if it belongs to a 243 ;; before the field can be modified (e.g. if it belongs to a
237 ;; choice widget). We try to compensate by checking the format 244 ;; choice widget). We try to compensate by checking the format
268 (let ((map (widget-get widget :keymap)) 275 (let ((map (widget-get widget :keymap))
269 (secret (widget-get widget :secret)) 276 (secret (widget-get widget :secret))
270 (secret-to to) 277 (secret-to to)
271 (size (widget-get widget :size)) 278 (size (widget-get widget :size))
272 (face (or (widget-get widget :value-face) 279 (face (or (widget-get widget :value-face)
273 'widget-field-face))) 280 'widget-field-face))
281 (help-echo (widget-get widget :help-echo))
282 (help-property (if (featurep 'balloon-help)
283 'balloon-help
284 'help-echo)))
285 (unless (or (stringp help-echo) (null help-echo))
286 (setq help-echo 'widget-mouse-help))
274 287
275 (when secret 288 (when secret
276 (while (and size 289 (while (and size
277 (not (zerop size)) 290 (not (zerop size))
278 (> secret-to from) 291 (> secret-to from)
289 302
290 (set-text-properties from to (list 'field widget 303 (set-text-properties from to (list 'field widget
291 'read-only nil 304 'read-only nil
292 'keymap map 305 'keymap map
293 'local-map map 306 'local-map map
307 help-property help-echo
294 'face face)) 308 'face face))
295 309
296 (when secret 310 (when secret
297 (save-excursion 311 (save-excursion
298 (goto-char from) 312 (goto-char from)
299 (while (< (point) secret-to) 313 (while (< (point) secret-to)
300 (let ((old (following-char))) 314 (let ((old (following-char)))
302 (put-text-property (point) (1+ (point)) 'secret old)) 316 (put-text-property (point) (1+ (point)) 'secret old))
303 (forward-char)))) 317 (forward-char))))
304 318
305 (unless (widget-get widget :size) 319 (unless (widget-get widget :size)
306 (add-text-properties to (1+ to) (list 'field widget 320 (add-text-properties to (1+ to) (list 'field widget
321 help-property help-echo
307 'face face))) 322 'face face)))
308 (add-text-properties to (1+ to) (list 'local-map map 323 (add-text-properties to (1+ to) (list 'local-map map
309 'keymap map)))) 324 'keymap map))))
310 325
311 (defun widget-specify-button (widget from to) 326 (defun widget-specify-button (widget from to)
312 ;; Specify button for WIDGET between FROM and TO. 327 ;; Specify button for WIDGET between FROM and TO.
313 (let ((face (widget-apply widget :button-face-get))) 328 (let ((face (widget-apply widget :button-face-get))
329 (help-echo (widget-get widget :help-echo))
330 (help-property (if (featurep 'balloon-help)
331 'balloon-help
332 'help-echo)))
333 (unless (or (null help-echo) (stringp help-echo))
334 (setq help-echo 'widget-mouse-help))
314 (add-text-properties from to (list 'button widget 335 (add-text-properties from to (list 'button widget
315 'mouse-face widget-mouse-face 336 'mouse-face widget-mouse-face
316 'start-open t 337 'start-open t
317 'end-open t 338 'end-open t
339 help-property help-echo
318 'face face)))) 340 'face face))))
341
342 (defun widget-mouse-help (extent)
343 "Find mouse help string for button in extent."
344 (let* ((widget (widget-at (extent-start-position extent)))
345 (help-echo (and widget (widget-get widget :help-echo))))
346 (cond ((stringp help-echo)
347 help-echo)
348 ((and (symbolp help-echo) (fboundp help-echo)
349 (stringp (setq help-echo (funcall help-echo widget))))
350 help-echo)
351 (t
352 (format "(widget %S :help-echo %S)" widget help-echo)))))
319 353
320 (defun widget-specify-sample (widget from to) 354 (defun widget-specify-sample (widget from to)
321 ;; Specify sample for WIDGET between FROM and TO. 355 ;; Specify sample for WIDGET between FROM and TO.
322 (let ((face (widget-apply widget :sample-face-get))) 356 (let ((face (widget-apply widget :sample-face-get)))
323 (when face 357 (when face
381 (widget-member (get (car widget) 'widget-type) property)) 415 (widget-member (get (car widget) 'widget-type) property))
382 (t nil))) 416 (t nil)))
383 417
384 (defun widget-apply (widget property &rest args) 418 (defun widget-apply (widget property &rest args)
385 "Apply the value of WIDGET's PROPERTY to the widget itself. 419 "Apply the value of WIDGET's PROPERTY to the widget itself.
386 ARGS are passed as extra argments to the function." 420 ARGS are passed as extra arguments to the function."
387 (apply (widget-get widget property) widget args)) 421 (apply (widget-get widget property) widget args))
388 422
389 (defun widget-value (widget) 423 (defun widget-value (widget)
390 "Extract the current value of WIDGET." 424 "Extract the current value of WIDGET."
391 (widget-apply widget 425 (widget-apply widget
420 :group 'widgets 454 :group 'widgets
421 :type 'boolean) 455 :type 'boolean)
422 456
423 (defun widget-glyph-insert (widget tag image) 457 (defun widget-glyph-insert (widget tag image)
424 "In WIDGET, insert the text TAG or, if supported, IMAGE. 458 "In WIDGET, insert the text TAG or, if supported, IMAGE.
425 IMAGE should be a name sans extension of an xpm or xbm file located in 459 IMAGE should either be a glyph, or a name sans extension of an xpm or
426 `widget-glyph-directory'" 460 xbm file located in `widget-glyph-directory'.
427 (if (and (string-match "XEmacs" emacs-version) 461
428 widget-glyph-enable 462 WARNING: If you call this with a glyph, and you want theuser to be
429 (fboundp 'make-glyph) 463 able to activate the glyph, make sure it is unique. If you use the
430 image) 464 same glyph for multiple widgets, "
431 (let ((file (concat widget-glyph-directory 465 (cond ((not (and (string-match "XEmacs" emacs-version)
432 (if (string-match "/\\'" widget-glyph-directory) 466 widget-glyph-enable
433 "" 467 (fboundp 'make-glyph)
434 "/") 468 image))
435 image 469 ;; We don't want or can't use glyphs.
436 (if (featurep 'xpm) ".xpm" ".xbm")))) 470 (insert tag))
437 (if (file-readable-p file) 471 ((and (fboundp 'glyphp)
438 (widget-glyph-insert-glyph widget tag (make-glyph file)) 472 (glyphp image))
439 ;; File not readable, give up. 473 ;; Already a glyph. Insert it.
440 (insert tag))) 474 (widget-glyph-insert-glyph widget tag image))
441 ;; We don't want or can't use glyphs. 475 (t
442 (insert tag))) 476 ;; A string. Look it up in.
477 (let ((file (concat widget-glyph-directory
478 (if (string-match "/\\'" widget-glyph-directory)
479 ""
480 "/")
481 image
482 (if (featurep 'xpm) ".xpm" ".xbm"))))
483 (if (file-readable-p file)
484 (widget-glyph-insert-glyph widget tag (make-glyph file))
485 ;; File not readable, give up.
486 (insert tag))))))
443 487
444 (defun widget-glyph-insert-glyph (widget tag glyph) 488 (defun widget-glyph-insert-glyph (widget tag glyph)
445 "In WIDGET, with alternative text TAG, insert GLYPH." 489 "In WIDGET, with alternative text TAG, insert GLYPH."
446 (set-glyph-image glyph (cons 'tty tag)) 490 (set-glyph-image glyph (cons 'tty tag))
447 (set-glyph-property glyph 'widget widget) 491 (set-glyph-property glyph 'widget widget)
448 (insert "*") 492 (insert "*")
449 (add-text-properties (1- (point)) (point) 493 (add-text-properties (1- (point)) (point)
450 (list 'invisible t 494 (list 'invisible t
451 'end-glyph glyph))) 495 'end-glyph glyph))
496 (let ((help-echo (widget-get widget :help-echo)))
497 (when help-echo
498 (let ((extent (extent-at (1- (point)) nil 'end-glyph))
499 (help-property (if (featurep 'balloon-help)
500 'balloon-help
501 'help-echo)))
502 (set-extent-property extent help-property (if (stringp help-echo)
503 help-echo
504 'widget-mouse-help))))))
452 505
453 ;;; Creating Widgets. 506 ;;; Creating Widgets.
454 507
455 ;;;###autoload 508 ;;;###autoload
456 (defun widget-create (type &rest args) 509 (defun widget-create (type &rest args)
551 after-change-functions 604 after-change-functions
552 (from (point))) 605 (from (point)))
553 (apply 'insert args) 606 (apply 'insert args)
554 (widget-specify-text from (point)))) 607 (widget-specify-text from (point))))
555 608
556 ;;; Keymap and Comands. 609 ;;; Keymap and Commands.
557 610
558 (defvar widget-keymap nil 611 (defvar widget-keymap nil
559 "Keymap containing useful binding for buffers containing widgets. 612 "Keymap containing useful binding for buffers containing widgets.
560 Recommended as a parent keymap for modes using widgets.") 613 Recommended as a parent keymap for modes using widgets.")
561 614
1139 1192
1140 ;;; The `link' Widget. 1193 ;;; The `link' Widget.
1141 1194
1142 (define-widget 'link 'item 1195 (define-widget 'link 'item
1143 "An embedded link." 1196 "An embedded link."
1144 :help-echo "Push me to follow the link." 1197 :help-echo "Follow the link."
1145 :format "%[_%t_%]") 1198 :format "%[_%t_%]")
1146 1199
1147 ;;; The `info-link' Widget. 1200 ;;; The `info-link' Widget.
1148 1201
1149 (define-widget 'info-link 'link 1202 (define-widget 'info-link 'link
1466 (widget-get widget :indent) 1519 (widget-get widget :indent)
1467 (insert-char ? (widget-get widget :indent))) 1520 (insert-char ? (widget-get widget :indent)))
1468 (widget-specify-insert 1521 (widget-specify-insert
1469 (let* ((children (widget-get widget :children)) 1522 (let* ((children (widget-get widget :children))
1470 (buttons (widget-get widget :buttons)) 1523 (buttons (widget-get widget :buttons))
1524 (button-args (or (widget-get type :sibling-args)
1525 (widget-get widget :button-args)))
1471 (from (point)) 1526 (from (point))
1472 child button) 1527 child button)
1473 (insert (widget-get widget :entry-format)) 1528 (insert (widget-get widget :entry-format))
1474 (goto-char from) 1529 (goto-char from)
1475 ;; Parse % escapes in format. 1530 ;; Parse % escapes in format.
1477 (let ((escape (aref (match-string 1) 0))) 1532 (let ((escape (aref (match-string 1) 0)))
1478 (replace-match "" t t) 1533 (replace-match "" t t)
1479 (cond ((eq escape ?%) 1534 (cond ((eq escape ?%)
1480 (insert "%")) 1535 (insert "%"))
1481 ((eq escape ?b) 1536 ((eq escape ?b)
1482 (setq button (widget-create-child-and-convert 1537 (setq button (apply 'widget-create-child-and-convert
1483 widget 'checkbox :value (not (null chosen))))) 1538 widget 'checkbox
1539 :value (not (null chosen))
1540 button-args)))
1484 ((eq escape ?v) 1541 ((eq escape ?v)
1485 (setq child 1542 (setq child
1486 (cond ((not chosen) 1543 (cond ((not chosen)
1487 (widget-create-child widget type)) 1544 (widget-create-child widget type))
1488 ((widget-get type :inline) 1545 ((widget-get type :inline)
1645 (insert-char ? (widget-get widget :indent))) 1702 (insert-char ? (widget-get widget :indent)))
1646 (widget-specify-insert 1703 (widget-specify-insert
1647 (let* ((value (widget-get widget :value)) 1704 (let* ((value (widget-get widget :value))
1648 (children (widget-get widget :children)) 1705 (children (widget-get widget :children))
1649 (buttons (widget-get widget :buttons)) 1706 (buttons (widget-get widget :buttons))
1707 (button-args (or (widget-get type :sibling-args)
1708 (widget-get widget :button-args)))
1650 (from (point)) 1709 (from (point))
1651 (chosen (and (null (widget-get widget :choice)) 1710 (chosen (and (null (widget-get widget :choice))
1652 (widget-apply type :match value))) 1711 (widget-apply type :match value)))
1653 child button) 1712 child button)
1654 (insert (widget-get widget :entry-format)) 1713 (insert (widget-get widget :entry-format))
1658 (let ((escape (aref (match-string 1) 0))) 1717 (let ((escape (aref (match-string 1) 0)))
1659 (replace-match "" t t) 1718 (replace-match "" t t)
1660 (cond ((eq escape ?%) 1719 (cond ((eq escape ?%)
1661 (insert "%")) 1720 (insert "%"))
1662 ((eq escape ?b) 1721 ((eq escape ?b)
1663 (setq button (widget-create-child-and-convert 1722 (setq button (apply 'widget-create-child-and-convert
1664 widget 'radio-button 1723 widget 'radio-button
1665 :value (not (null chosen))))) 1724 :value (not (null chosen))
1725 button-args)))
1666 ((eq escape ?v) 1726 ((eq escape ?v)
1667 (setq child (if chosen 1727 (setq child (if chosen
1668 (widget-create-child-value 1728 (widget-create-child-value
1669 widget type value) 1729 widget type value)
1670 (widget-create-child widget type)))) 1730 (widget-create-child widget type))))
1763 ;;; The `insert-button' Widget. 1823 ;;; The `insert-button' Widget.
1764 1824
1765 (define-widget 'insert-button 'push-button 1825 (define-widget 'insert-button 'push-button
1766 "An insert button for the `editable-list' widget." 1826 "An insert button for the `editable-list' widget."
1767 :tag "INS" 1827 :tag "INS"
1828 :help-echo "Insert a new item into the list at this position."
1768 :action 'widget-insert-button-action) 1829 :action 'widget-insert-button-action)
1769 1830
1770 (defun widget-insert-button-action (widget &optional event) 1831 (defun widget-insert-button-action (widget &optional event)
1771 ;; Ask the parent to insert a new item. 1832 ;; Ask the parent to insert a new item.
1772 (widget-apply (widget-get widget :parent) 1833 (widget-apply (widget-get widget :parent)
1775 ;;; The `delete-button' Widget. 1836 ;;; The `delete-button' Widget.
1776 1837
1777 (define-widget 'delete-button 'push-button 1838 (define-widget 'delete-button 'push-button
1778 "A delete button for the `editable-list' widget." 1839 "A delete button for the `editable-list' widget."
1779 :tag "DEL" 1840 :tag "DEL"
1841 :help-echo "Delete this item from the list."
1780 :action 'widget-delete-button-action) 1842 :action 'widget-delete-button-action)
1781 1843
1782 (defun widget-delete-button-action (widget &optional event) 1844 (defun widget-delete-button-action (widget &optional event)
1783 ;; Ask the parent to insert a new item. 1845 ;; Ask the parent to insert a new item.
1784 (widget-apply (widget-get widget :parent) 1846 (widget-apply (widget-get widget :parent)
1812 ;; We recognize the insert button. 1874 ;; We recognize the insert button.
1813 (let ((widget-push-button-gui widget-editable-list-gui)) 1875 (let ((widget-push-button-gui widget-editable-list-gui))
1814 (cond ((eq escape ?i) 1876 (cond ((eq escape ?i)
1815 (and (widget-get widget :indent) 1877 (and (widget-get widget :indent)
1816 (insert-char ? (widget-get widget :indent))) 1878 (insert-char ? (widget-get widget :indent)))
1817 (widget-create-child-and-convert widget 'insert-button)) 1879 (apply 'widget-create-child-and-convert
1880 widget 'insert-button
1881 (widget-get widget :append-button-args)))
1818 (t 1882 (t
1819 (widget-default-format-handler widget escape))))) 1883 (widget-default-format-handler widget escape)))))
1820 1884
1821 (defun widget-editable-list-value-create (widget) 1885 (defun widget-editable-list-value-create (widget)
1822 ;; Insert all values 1886 ;; Insert all values
1938 (let ((escape (aref (match-string 1) 0))) 2002 (let ((escape (aref (match-string 1) 0)))
1939 (replace-match "" t t) 2003 (replace-match "" t t)
1940 (cond ((eq escape ?%) 2004 (cond ((eq escape ?%)
1941 (insert "%")) 2005 (insert "%"))
1942 ((eq escape ?i) 2006 ((eq escape ?i)
1943 (setq insert (widget-create-child-and-convert 2007 (setq insert (apply 'widget-create-child-and-convert
1944 widget 'insert-button))) 2008 widget 'insert-button
2009 (widget-get widget :insert-button-args))))
1945 ((eq escape ?d) 2010 ((eq escape ?d)
1946 (setq delete (widget-create-child-and-convert 2011 (setq delete (apply 'widget-create-child-and-convert
1947 widget 'delete-button))) 2012 widget 'delete-button
2013 (widget-get widget :delete-button-args))))
1948 ((eq escape ?v) 2014 ((eq escape ?v)
1949 (if conv 2015 (if conv
1950 (setq child (widget-create-child-value 2016 (setq child (widget-create-child-value
1951 widget type value)) 2017 widget type value))
1952 (setq child (widget-create-child widget type)))) 2018 (setq child (widget-create-child widget type))))
2028 ;;; The `widget-help' Widget. 2094 ;;; The `widget-help' Widget.
2029 2095
2030 (define-widget 'widget-help 'push-button 2096 (define-widget 'widget-help 'push-button
2031 "The widget documentation button." 2097 "The widget documentation button."
2032 :format "%[[%t]%] %d" 2098 :format "%[[%t]%] %d"
2033 :help-echo "Push me to toggle the documentation." 2099 :help-echo "Toggle display of documentation."
2034 :action 'widget-help-action) 2100 :action 'widget-help-action)
2035 2101
2036 (defun widget-help-action (widget &optional event) 2102 (defun widget-help-action (widget &optional event)
2037 "Toggle documentation for WIDGET." 2103 "Toggle documentation for WIDGET."
2038 (let ((old (widget-get widget :doc)) 2104 (let ((old (widget-get widget :doc))
2259 2325
2260 ;;; The `color' Widget. 2326 ;;; The `color' Widget.
2261 2327
2262 (define-widget 'color-item 'choice-item 2328 (define-widget 'color-item 'choice-item
2263 "A color name (with sample)." 2329 "A color name (with sample)."
2264 :format "%v (%[sample%])\n" 2330 :format "%v (%{sample%})\n"
2265 :button-face-get 'widget-color-item-button-face-get) 2331 :button-face-get 'widget-color-item-button-face-get)
2266 2332
2267 (defun widget-color-item-button-face-get (widget) 2333 (defun widget-color-item-button-face-get (widget)
2268 ;; We create a face from the value. 2334 ;; We create a face from the value.
2269 (require 'facemenu) 2335 (require 'facemenu)