diff options
| author | Dave Love | 2000-08-20 18:34:24 +0000 |
|---|---|---|
| committer | Dave Love | 2000-08-20 18:34:24 +0000 |
| commit | 7fdbdbeadb334686d711f8be3c016ba84b383aa3 (patch) | |
| tree | ca582e8f9ff94ae654bfa379908b5f72cb92f151 | |
| parent | 35244a0ee5686e923418fefaa5c6c434e135033a (diff) | |
| download | emacs-7fdbdbeadb334686d711f8be3c016ba84b383aa3.tar.gz emacs-7fdbdbeadb334686d711f8be3c016ba84b383aa3.zip | |
(widget-choose, widget-choice-mouse-down-action):
Don't test x-popup-menu.
(function) <complete-function>: Complete only fbound symbols.
<validate, value>: New.
(variable) <complete-function>: Complete only bound symbols.
(coding-system): Add :base-only, :complete-function, :validate,
:value, :prompt-match.
(widget-coding-system-prompt-value): Use read-coding-system and
act on :base-only.
(editable-field): Add :help-echo.
(widget-push-button-gui, widget-push-button-cache)
(widget-gui-action, widget-editable-list-gui): COmment out, along
with uses.
(widget-at): Make arg optional.
(widget-echo-help): Adjust for current help-echo calling sequence.
(widget-specify-field, widget-specify-button)
(widget-specify-insert, widget-get-sibling, widget-image-find)
(widget-convert, widget-insert, widget-leave-text)
(widget-beginning-of-line, widget-end-of-line, widget-kill-line)
(widget-setup, widget-field-find, widget-before-change)
(widget-after-change, widget-default-complete)
(widget-default-create, widget-default-delete)
(widget-push-button-value-create, editable-field)
(widget-field-prompt-value, widget-field-validate)
(widget-choice-value-create, widget-choice-action)
(widget-choice-validate, widget-checklist-add-item)
(widget-radio-add-item, widget-radio-chosen)
(widget-radio-value-inline, widget-editable-list-value-create)
(widget-editable-list-entry-create)
(widget-documentation-link-add)
(widget-documentation-string-value-create)
(widget-regexp-validate, widget-file-complete)
(widget-sexp-validate, widget-plist-convert-widget)
(widget-plist-convert-widget, widget-alist-convert-widget)
(widget-alist-convert-widget, widget-color-complete): Simplify,
particularly to avoid bindings which aren't optimized out.
| -rw-r--r-- | lisp/wid-edit.el | 497 |
1 files changed, 251 insertions, 246 deletions
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index cd92824049a..0f50956654a 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el | |||
| @@ -23,6 +23,34 @@ | |||
| 23 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 23 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 24 | ;; Boston, MA 02111-1307, USA. | 24 | ;; Boston, MA 02111-1307, USA. |
| 25 | 25 | ||
| 26 | ;;; Wishlist items (from widget.texi): | ||
| 27 | |||
| 28 | ;; * The `menu-choice' tag should be prettier, something like the | ||
| 29 | ;; abbreviated menus in Open Look. | ||
| 30 | |||
| 31 | ;; * Finish `:tab-order'. | ||
| 32 | |||
| 33 | ;; * Make indentation work with glyphs and proportional fonts. | ||
| 34 | |||
| 35 | ;; * Add commands to show overview of object and class hierarchies to | ||
| 36 | ;; the browser. | ||
| 37 | |||
| 38 | ;; * Find a way to disable mouse highlight for inactive widgets. | ||
| 39 | |||
| 40 | ;; * Find a way to make glyphs look inactive. | ||
| 41 | |||
| 42 | ;; * Add `key-binding' widget. | ||
| 43 | |||
| 44 | ;; * Add `widget' widget for editing widget specifications. | ||
| 45 | |||
| 46 | ;; * Find clean way to implement variable length list. See | ||
| 47 | ;; `TeX-printer-list' for an explanation. | ||
| 48 | |||
| 49 | ;; * `C-h' in `widget-prompt-value' should give type specific help. | ||
| 50 | |||
| 51 | ;; * A mailto widget. [This should work OK as a url-link if with | ||
| 52 | ;; browse-url-browser-function' set up appropriately.] | ||
| 53 | |||
| 26 | ;;; Commentary: | 54 | ;;; Commentary: |
| 27 | ;; | 55 | ;; |
| 28 | ;; See `widget.el'. | 56 | ;; See `widget.el'. |
| @@ -176,8 +204,8 @@ mouse event, and the number of elements in items is less than | |||
| 176 | `widget-menu-max-size', a popup menu will be used, otherwise the | 204 | `widget-menu-max-size', a popup menu will be used, otherwise the |
| 177 | minibuffer." | 205 | minibuffer." |
| 178 | (cond ((and (< (length items) widget-menu-max-size) | 206 | (cond ((and (< (length items) widget-menu-max-size) |
| 179 | event (fboundp 'x-popup-menu) (display-mouse-p)) | 207 | event (display-mouse-p)) |
| 180 | ;; We are in Emacs-19, pressed by the mouse | 208 | ;; Mouse click. |
| 181 | (x-popup-menu event | 209 | (x-popup-menu event |
| 182 | (list title (cons "" items)))) | 210 | (list title (cons "" items)))) |
| 183 | ((or widget-menu-minibuffer-flag | 211 | ((or widget-menu-minibuffer-flag |
| @@ -193,11 +221,9 @@ minibuffer." | |||
| 193 | (t | 221 | (t |
| 194 | ;; Construct a menu of the choices | 222 | ;; Construct a menu of the choices |
| 195 | ;; and then use it for prompting for a single character. | 223 | ;; and then use it for prompting for a single character. |
| 196 | (let* ((overriding-terminal-local-map | 224 | (let* ((overriding-terminal-local-map (make-sparse-keymap)) |
| 197 | (make-sparse-keymap)) | 225 | (next-digit ?0) |
| 198 | map choice (next-digit ?0) | 226 | map choice some-choice-enabled value) |
| 199 | some-choice-enabled | ||
| 200 | value) | ||
| 201 | ;; Define SPC as a prefix char to get to this menu. | 227 | ;; Define SPC as a prefix char to get to this menu. |
| 202 | (define-key overriding-terminal-local-map " " | 228 | (define-key overriding-terminal-local-map " " |
| 203 | (setq map (make-sparse-keymap title))) | 229 | (setq map (make-sparse-keymap title))) |
| @@ -292,19 +318,16 @@ new value.") | |||
| 292 | (widget-field-add-space | 318 | (widget-field-add-space |
| 293 | (insert-and-inherit " "))) | 319 | (insert-and-inherit " "))) |
| 294 | (setq to (point))) | 320 | (setq to (point))) |
| 295 | (let ((map (widget-get widget :keymap)) | 321 | (let ((overlay (make-overlay from to nil |
| 296 | (face (or (widget-get widget :value-face) 'widget-field-face)) | ||
| 297 | (help-echo (widget-get widget :help-echo)) | ||
| 298 | (overlay (make-overlay from to nil | ||
| 299 | nil (or (not widget-field-add-space) | 322 | nil (or (not widget-field-add-space) |
| 300 | (widget-get widget :size))))) | 323 | (widget-get widget :size))))) |
| 301 | (widget-put widget :field-overlay overlay) | 324 | (widget-put widget :field-overlay overlay) |
| 302 | ;;(overlay-put overlay 'detachable nil) | 325 | ;;(overlay-put overlay 'detachable nil) |
| 303 | (overlay-put overlay 'field widget) | 326 | (overlay-put overlay 'field widget) |
| 304 | (overlay-put overlay 'keymap map) | 327 | (overlay-put overlay 'keymap (widget-get widget :keymap)) |
| 305 | (overlay-put overlay 'face face) | 328 | (overlay-put overlay 'face (or (widget-get widget :value-face) |
| 306 | ;;(overlay-put overlay 'balloon-help help-echo) | 329 | 'widget-field-face)) |
| 307 | (overlay-put overlay 'help-echo help-echo)) | 330 | (overlay-put overlay 'help-echo (widget-get widget :help-echo))) |
| 308 | (widget-specify-secret widget)) | 331 | (widget-specify-secret widget)) |
| 309 | 332 | ||
| 310 | (defun widget-specify-secret (field) | 333 | (defun widget-specify-secret (field) |
| @@ -327,23 +350,20 @@ new value.") | |||
| 327 | 350 | ||
| 328 | (defun widget-specify-button (widget from to) | 351 | (defun widget-specify-button (widget from to) |
| 329 | "Specify button for WIDGET between FROM and TO." | 352 | "Specify button for WIDGET between FROM and TO." |
| 330 | (let ((face (widget-apply widget :button-face-get)) | 353 | (let ((overlay (make-overlay from to nil t nil))) |
| 331 | (help-echo (widget-get widget :help-echo)) | ||
| 332 | (overlay (make-overlay from to nil t nil))) | ||
| 333 | (widget-put widget :button-overlay overlay) | 354 | (widget-put widget :button-overlay overlay) |
| 334 | (overlay-put overlay 'button widget) | 355 | (overlay-put overlay 'button widget) |
| 356 | (overlay-put overlay 'keymap (widget-get widget :keymap)) | ||
| 335 | ;; We want to avoid the face with image buttons. | 357 | ;; We want to avoid the face with image buttons. |
| 336 | (unless (widget-get widget :suppress-face) | 358 | (unless (widget-get widget :suppress-face) |
| 337 | (overlay-put overlay 'face face) | 359 | (overlay-put overlay 'face (widget-apply widget :button-face-get)) |
| 338 | (overlay-put overlay 'mouse-face widget-mouse-face)) | 360 | (overlay-put overlay 'mouse-face widget-mouse-face)) |
| 339 | ;;(overlay-put overlay 'balloon-help help-echo) | 361 | (overlay-put overlay 'help-echo (widget-get widget :help-echo)))) |
| 340 | (overlay-put overlay 'help-echo help-echo))) | ||
| 341 | 362 | ||
| 342 | (defun widget-specify-sample (widget from to) | 363 | (defun widget-specify-sample (widget from to) |
| 343 | "Specify sample for WIDGET between FROM and TO." | 364 | "Specify sample for WIDGET between FROM and TO." |
| 344 | (let ((face (widget-apply widget :sample-face-get)) | 365 | (let ((overlay (make-overlay from to nil t nil))) |
| 345 | (overlay (make-overlay from to nil t nil))) | 366 | (overlay-put overlay 'face (widget-apply widget :sample-face-get)) |
| 346 | (overlay-put overlay 'face face) | ||
| 347 | (widget-put widget :sample-overlay overlay))) | 367 | (widget-put widget :sample-overlay overlay))) |
| 348 | 368 | ||
| 349 | (defun widget-specify-doc (widget from to) | 369 | (defun widget-specify-doc (widget from to) |
| @@ -357,9 +377,8 @@ new value.") | |||
| 357 | "Execute FORM without inheriting any text properties." | 377 | "Execute FORM without inheriting any text properties." |
| 358 | `(save-restriction | 378 | `(save-restriction |
| 359 | (let ((inhibit-read-only t) | 379 | (let ((inhibit-read-only t) |
| 360 | result | 380 | (inhibit-modification-hooks t) |
| 361 | before-change-functions | 381 | result) |
| 362 | after-change-functions) | ||
| 363 | (insert "<>") | 382 | (insert "<>") |
| 364 | (narrow-to-region (- (point) 2) (point)) | 383 | (narrow-to-region (- (point) 2) (point)) |
| 365 | (goto-char (1+ (point-min))) | 384 | (goto-char (1+ (point-min))) |
| @@ -479,8 +498,7 @@ The current value is assumed to be VALUE, unless UNBOUND is non-nil." | |||
| 479 | (defun widget-get-sibling (widget) | 498 | (defun widget-get-sibling (widget) |
| 480 | "Get the item WIDGET is assumed to toggle. | 499 | "Get the item WIDGET is assumed to toggle. |
| 481 | This is only meaningful for radio buttons or checkboxes in a list." | 500 | This is only meaningful for radio buttons or checkboxes in a list." |
| 482 | (let* ((parent (widget-get widget :parent)) | 501 | (let* ((children (widget-get (widget-get widget :parent) :children)) |
| 483 | (children (widget-get parent :children)) | ||
| 484 | child) | 502 | child) |
| 485 | (catch 'child | 503 | (catch 'child |
| 486 | (while children | 504 | (while children |
| @@ -551,7 +569,6 @@ extension (xpm, xbm, gif, jpg, or png) located in | |||
| 551 | ((stringp image) | 569 | ((stringp image) |
| 552 | ;; A string. Look it up in relevant directories. | 570 | ;; A string. Look it up in relevant directories. |
| 553 | (let* ((load-path (cons widget-image-directory load-path)) | 571 | (let* ((load-path (cons widget-image-directory load-path)) |
| 554 | (formats widget-image-conversion) | ||
| 555 | specs) | 572 | specs) |
| 556 | (dolist (elt widget-image-conversion) | 573 | (dolist (elt widget-image-conversion) |
| 557 | (dolist (ext (cdr elt)) | 574 | (dolist (ext (cdr elt)) |
| @@ -659,17 +676,15 @@ The optional ARGS are additional keyword arguments." | |||
| 659 | (keys args)) | 676 | (keys args)) |
| 660 | ;; First set the :args keyword. | 677 | ;; First set the :args keyword. |
| 661 | (while (cdr current) ;Look in the type. | 678 | (while (cdr current) ;Look in the type. |
| 662 | (let ((next (car (cdr current)))) | 679 | (if (keywordp (car (cdr current))) |
| 663 | (if (keywordp next) | 680 | (setq current (cdr (cdr current))) |
| 664 | (setq current (cdr (cdr current))) | 681 | (setcdr current (list :args (cdr current))) |
| 665 | (setcdr current (list :args (cdr current))) | 682 | (setq current nil))) |
| 666 | (setq current nil)))) | ||
| 667 | (while args ;Look in the args. | 683 | (while args ;Look in the args. |
| 668 | (let ((next (nth 0 args))) | 684 | (if (keywordp (nth 0 args)) |
| 669 | (if (keywordp next) | 685 | (setq args (nthcdr 2 args)) |
| 670 | (setq args (nthcdr 2 args)) | 686 | (widget-put widget :args args) |
| 671 | (widget-put widget :args args) | 687 | (setq args nil))) |
| 672 | (setq args nil)))) | ||
| 673 | ;; Then Convert the widget. | 688 | ;; Then Convert the widget. |
| 674 | (setq type widget) | 689 | (setq type widget) |
| 675 | (while type | 690 | (while type |
| @@ -687,18 +702,17 @@ The optional ARGS are additional keyword arguments." | |||
| 687 | (setq keys nil)))) | 702 | (setq keys nil)))) |
| 688 | ;; Convert the :value to internal format. | 703 | ;; Convert the :value to internal format. |
| 689 | (if (widget-member widget :value) | 704 | (if (widget-member widget :value) |
| 690 | (let ((value (widget-get widget :value))) | 705 | (widget-put widget |
| 691 | (widget-put widget | 706 | :value (widget-apply widget |
| 692 | :value (widget-apply widget :value-to-internal value)))) | 707 | :value-to-internal |
| 708 | (widget-get widget :value)))) | ||
| 693 | ;; Return the newly create widget. | 709 | ;; Return the newly create widget. |
| 694 | widget)) | 710 | widget)) |
| 695 | 711 | ||
| 696 | (defun widget-insert (&rest args) | 712 | (defun widget-insert (&rest args) |
| 697 | "Call `insert' with ARGS and make the text read only." | 713 | "Call `insert' with ARGS even if surrounding text is read only." |
| 698 | (let ((inhibit-read-only t) | 714 | (let ((inhibit-read-only t) |
| 699 | before-change-functions | 715 | (inhibit-modification-hooks t)) |
| 700 | after-change-functions | ||
| 701 | (from (point))) | ||
| 702 | (apply 'insert args))) | 716 | (apply 'insert args))) |
| 703 | 717 | ||
| 704 | (defun widget-convert-text (type from to | 718 | (defun widget-convert-text (type from to |
| @@ -731,15 +745,12 @@ button end points." | |||
| 731 | 745 | ||
| 732 | (defun widget-leave-text (widget) | 746 | (defun widget-leave-text (widget) |
| 733 | "Remove markers and overlays from WIDGET and its children." | 747 | "Remove markers and overlays from WIDGET and its children." |
| 734 | (let ((from (widget-get widget :from)) | 748 | (let ((button (widget-get widget :button-overlay)) |
| 735 | (to (widget-get widget :to)) | ||
| 736 | (button (widget-get widget :button-overlay)) | ||
| 737 | (sample (widget-get widget :sample-overlay)) | 749 | (sample (widget-get widget :sample-overlay)) |
| 738 | (doc (widget-get widget :doc-overlay)) | 750 | (doc (widget-get widget :doc-overlay)) |
| 739 | (field (widget-get widget :field-overlay)) | 751 | (field (widget-get widget :field-overlay))) |
| 740 | (children (widget-get widget :children))) | 752 | (set-marker (widget-get widget :from) nil) |
| 741 | (set-marker from nil) | 753 | (set-marker (widget-get widget :to) nil) |
| 742 | (set-marker to nil) | ||
| 743 | (when button | 754 | (when button |
| 744 | (delete-overlay button)) | 755 | (delete-overlay button)) |
| 745 | (when sample | 756 | (when sample |
| @@ -748,7 +759,7 @@ button end points." | |||
| 748 | (delete-overlay doc)) | 759 | (delete-overlay doc)) |
| 749 | (when field | 760 | (when field |
| 750 | (delete-overlay field)) | 761 | (delete-overlay field)) |
| 751 | (mapc 'widget-leave-text children))) | 762 | (mapc 'widget-leave-text (widget-get widget :children)))) |
| 752 | 763 | ||
| 753 | ;;; Keymap and Commands. | 764 | ;;; Keymap and Commands. |
| 754 | 765 | ||
| @@ -965,29 +976,26 @@ With optional ARG, move across that many fields." | |||
| 965 | "Go to beginning of field or beginning of line, whichever is first." | 976 | "Go to beginning of field or beginning of line, whichever is first." |
| 966 | (interactive) | 977 | (interactive) |
| 967 | (let* ((field (widget-field-find (point))) | 978 | (let* ((field (widget-field-find (point))) |
| 968 | (start (and field (widget-field-start field))) | 979 | (start (and field (widget-field-start field)))) |
| 969 | (bol (line-beginning-position))) | ||
| 970 | (goto-char (if start | 980 | (goto-char (if start |
| 971 | (max start bol) | 981 | (max start (line-beginning-position)) |
| 972 | bol)))) | 982 | (line-beginning-position))))) |
| 973 | 983 | ||
| 974 | (defun widget-end-of-line () | 984 | (defun widget-end-of-line () |
| 975 | "Go to end of field or end of line, whichever is first." | 985 | "Go to end of field or end of line, whichever is first." |
| 976 | (interactive) | 986 | (interactive) |
| 977 | (let* ((field (widget-field-find (point))) | 987 | (let* ((field (widget-field-find (point))) |
| 978 | (end (and field (widget-field-end field))) | 988 | (end (and field (widget-field-end field)))) |
| 979 | (eol (line-end-position))) | ||
| 980 | (goto-char (if end | 989 | (goto-char (if end |
| 981 | (min end eol) | 990 | (min end (line-end-position)) |
| 982 | eol)))) | 991 | (line-end-position))))) |
| 983 | 992 | ||
| 984 | (defun widget-kill-line () | 993 | (defun widget-kill-line () |
| 985 | "Kill to end of field or end of line, whichever is first." | 994 | "Kill to end of field or end of line, whichever is first." |
| 986 | (interactive) | 995 | (interactive) |
| 987 | (let* ((field (widget-field-find (point))) | 996 | (let* ((field (widget-field-find (point))) |
| 988 | (newline (save-excursion (forward-line 1) (point))) | ||
| 989 | (end (and field (widget-field-end field)))) | 997 | (end (and field (widget-field-end field)))) |
| 990 | (if (and field (> newline end)) | 998 | (if (and field (> (line-beginning-position 2) end)) |
| 991 | (kill-region (point) end) | 999 | (kill-region (point) end) |
| 992 | (call-interactively 'kill-line)))) | 1000 | (call-interactively 'kill-line)))) |
| 993 | 1001 | ||
| @@ -1019,8 +1027,7 @@ When not inside a field, move to the previous button or field." | |||
| 1019 | (defun widget-setup () | 1027 | (defun widget-setup () |
| 1020 | "Setup current buffer so editing string widgets works." | 1028 | "Setup current buffer so editing string widgets works." |
| 1021 | (let ((inhibit-read-only t) | 1029 | (let ((inhibit-read-only t) |
| 1022 | (after-change-functions nil) | 1030 | (inhibit-modification-hooks t) |
| 1023 | before-change-functions | ||
| 1024 | field) | 1031 | field) |
| 1025 | (while widget-field-new | 1032 | (while widget-field-new |
| 1026 | (setq field (car widget-field-new) | 1033 | (setq field (car widget-field-new) |
| @@ -1070,12 +1077,11 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." | |||
| 1070 | (while fields | 1077 | (while fields |
| 1071 | (setq field (car fields) | 1078 | (setq field (car fields) |
| 1072 | fields (cdr fields)) | 1079 | fields (cdr fields)) |
| 1073 | (let ((start (widget-field-start field)) | 1080 | (when (and (<= (widget-field-start field) pos) |
| 1074 | (end (widget-field-end field))) | 1081 | (<= pos (widget-field-end field))) |
| 1075 | (when (and (<= start pos) (<= pos end)) | 1082 | (when found |
| 1076 | (when found | 1083 | (error "Overlapping fields")) |
| 1077 | (debug "Overlapping fields")) | 1084 | (setq found field))) |
| 1078 | (setq found field)))) | ||
| 1079 | found)) | 1085 | found)) |
| 1080 | 1086 | ||
| 1081 | (defun widget-before-change (from to) | 1087 | (defun widget-before-change (from to) |
| @@ -1093,9 +1099,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." | |||
| 1093 | (signal 'text-read-only | 1099 | (signal 'text-read-only |
| 1094 | '("Attempt to change text outside editable field"))) | 1100 | '("Attempt to change text outside editable field"))) |
| 1095 | (widget-field-use-before-change | 1101 | (widget-field-use-before-change |
| 1096 | (condition-case nil | 1102 | (widget-apply from-field :notify from-field)))))) |
| 1097 | (widget-apply from-field :notify from-field) | ||
| 1098 | (error (debug "Before Change")))))))) | ||
| 1099 | 1103 | ||
| 1100 | (defun widget-add-change () | 1104 | (defun widget-add-change () |
| 1101 | (make-local-hook 'post-command-hook) | 1105 | (make-local-hook 'post-command-hook) |
| @@ -1107,37 +1111,35 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." | |||
| 1107 | 1111 | ||
| 1108 | (defun widget-after-change (from to old) | 1112 | (defun widget-after-change (from to old) |
| 1109 | "Adjust field size and text properties." | 1113 | "Adjust field size and text properties." |
| 1110 | (condition-case nil | 1114 | (let ((field (widget-field-find from)) |
| 1111 | (let ((field (widget-field-find from)) | 1115 | (other (widget-field-find to))) |
| 1112 | (other (widget-field-find to))) | 1116 | (when field |
| 1113 | (when field | 1117 | (unless (eq field other) |
| 1114 | (unless (eq field other) | 1118 | (error "Change in different fields")) |
| 1115 | (debug "Change in different fields")) | 1119 | (let ((size (widget-get field :size))) |
| 1116 | (let ((size (widget-get field :size))) | 1120 | (when size |
| 1117 | (when size | 1121 | (let ((begin (widget-field-start field)) |
| 1118 | (let ((begin (widget-field-start field)) | 1122 | (end (widget-field-end field))) |
| 1119 | (end (widget-field-end field))) | 1123 | (cond ((< (- end begin) size) |
| 1120 | (cond ((< (- end begin) size) | 1124 | ;; Field too small. |
| 1121 | ;; Field too small. | 1125 | (save-excursion |
| 1122 | (save-excursion | 1126 | (goto-char end) |
| 1123 | (goto-char end) | 1127 | (insert-char ?\ (- (+ begin size) end)))) |
| 1124 | (insert-char ?\ (- (+ begin size) end)))) | 1128 | ((> (- end begin) size) |
| 1125 | ((> (- end begin) size) | 1129 | ;; Field too large and |
| 1126 | ;; Field too large and | 1130 | (if (or (< (point) (+ begin size)) |
| 1127 | (if (or (< (point) (+ begin size)) | 1131 | (> (point) end)) |
| 1128 | (> (point) end)) | 1132 | ;; Point is outside extra space. |
| 1129 | ;; Point is outside extra space. | 1133 | (setq begin (+ begin size)) |
| 1130 | (setq begin (+ begin size)) | 1134 | ;; Point is within the extra space. |
| 1131 | ;; Point is within the extra space. | 1135 | (setq begin (point))) |
| 1132 | (setq begin (point))) | 1136 | (save-excursion |
| 1133 | (save-excursion | 1137 | (goto-char end) |
| 1134 | (goto-char end) | 1138 | (while (and (eq (preceding-char) ?\ ) |
| 1135 | (while (and (eq (preceding-char) ?\ ) | 1139 | (> (point) begin)) |
| 1136 | (> (point) begin)) | 1140 | (delete-backward-char 1))))))) |
| 1137 | (delete-backward-char 1))))))) | 1141 | (widget-specify-secret field)) |
| 1138 | (widget-specify-secret field)) | 1142 | (widget-apply field :notify field)))) |
| 1139 | (widget-apply field :notify field))) | ||
| 1140 | (error (debug "After Change")))) | ||
| 1141 | 1143 | ||
| 1142 | ;;; Widget Functions | 1144 | ;;; Widget Functions |
| 1143 | ;; | 1145 | ;; |
| @@ -1218,8 +1220,8 @@ Optional EVENT is the event that triggered the action." | |||
| 1218 | (defun widget-default-complete (widget) | 1220 | (defun widget-default-complete (widget) |
| 1219 | "Call the value of the :complete-function property of WIDGET. | 1221 | "Call the value of the :complete-function property of WIDGET. |
| 1220 | If that does not exists, call the value of `widget-complete-field'." | 1222 | If that does not exists, call the value of `widget-complete-field'." |
| 1221 | (let ((fun (widget-get widget :complete-function))) | 1223 | (call-interactively (or (widget-get widget :complete-function) |
| 1222 | (call-interactively (or fun widget-complete-field)))) | 1224 | widget-complete-field))) |
| 1223 | 1225 | ||
| 1224 | (defun widget-default-create (widget) | 1226 | (defun widget-default-create (widget) |
| 1225 | "Create WIDGET at point in the current buffer." | 1227 | "Create WIDGET at point in the current buffer." |
| @@ -1233,8 +1235,8 @@ If that does not exists, call the value of `widget-complete-field'." | |||
| 1233 | (goto-char from) | 1235 | (goto-char from) |
| 1234 | ;; Parse escapes in format. | 1236 | ;; Parse escapes in format. |
| 1235 | (while (re-search-forward "%\\(.\\)" nil t) | 1237 | (while (re-search-forward "%\\(.\\)" nil t) |
| 1236 | (let ((escape (aref (match-string 1) 0))) | 1238 | (let ((escape (char-after (match-beginning 1)))) |
| 1237 | (replace-match "" t t) | 1239 | (delete-backward-char 2) |
| 1238 | (cond ((eq escape ?%) | 1240 | (cond ((eq escape ?%) |
| 1239 | (insert ?%)) | 1241 | (insert ?%)) |
| 1240 | ((eq escape ?\[) | 1242 | ((eq escape ?\[) |
| @@ -1286,8 +1288,8 @@ If that does not exists, call the value of `widget-complete-field'." | |||
| 1286 | (when value-pos | 1288 | (when value-pos |
| 1287 | (goto-char value-pos) | 1289 | (goto-char value-pos) |
| 1288 | (widget-apply widget :value-create))) | 1290 | (widget-apply widget :value-create))) |
| 1289 | (let ((from (copy-marker (point-min))) | 1291 | (let ((from (point-min-marker)) |
| 1290 | (to (copy-marker (point-max)))) | 1292 | (to (point-max-marker))) |
| 1291 | (set-marker-insertion-type from t) | 1293 | (set-marker-insertion-type from t) |
| 1292 | (set-marker-insertion-type to nil) | 1294 | (set-marker-insertion-type to nil) |
| 1293 | (widget-put widget :from from) | 1295 | (widget-put widget :from from) |
| @@ -1354,8 +1356,7 @@ If that does not exists, call the value of `widget-complete-field'." | |||
| 1354 | (button-overlay (widget-get widget :button-overlay)) | 1356 | (button-overlay (widget-get widget :button-overlay)) |
| 1355 | (sample-overlay (widget-get widget :sample-overlay)) | 1357 | (sample-overlay (widget-get widget :sample-overlay)) |
| 1356 | (doc-overlay (widget-get widget :doc-overlay)) | 1358 | (doc-overlay (widget-get widget :doc-overlay)) |
| 1357 | before-change-functions | 1359 | (inhibit-modification-hooks t) |
| 1358 | after-change-functions | ||
| 1359 | (inhibit-read-only t)) | 1360 | (inhibit-read-only t)) |
| 1360 | (widget-apply widget :value-delete) | 1361 | (widget-apply widget :value-delete) |
| 1361 | (when inactive-overlay | 1362 | (when inactive-overlay |
| @@ -1438,10 +1439,10 @@ If that does not exists, call the value of `widget-complete-field'." | |||
| 1438 | (defun widget-default-prompt-value (widget prompt value unbound) | 1439 | (defun widget-default-prompt-value (widget prompt value unbound) |
| 1439 | "Read an arbitrary value. Stolen from `set-variable'." | 1440 | "Read an arbitrary value. Stolen from `set-variable'." |
| 1440 | ;; (let ((initial (if unbound | 1441 | ;; (let ((initial (if unbound |
| 1441 | nil | 1442 | ;; nil |
| 1442 | ;; It would be nice if we could do a `(cons val 1)' here. | 1443 | ;; It would be nice if we could do a `(cons val 1)' here. |
| 1443 | ;; (prin1-to-string (custom-quote value)))))) | 1444 | ;; (prin1-to-string (custom-quote value)))))) |
| 1444 | (eval-minibuffer prompt )) | 1445 | (eval-minibuffer prompt)) |
| 1445 | 1446 | ||
| 1446 | ;;; The `item' Widget. | 1447 | ;;; The `item' Widget. |
| 1447 | 1448 | ||
| @@ -1490,13 +1491,13 @@ If END is omitted, it defaults to the length of LIST." | |||
| 1490 | 1491 | ||
| 1491 | ;;; The `push-button' Widget. | 1492 | ;;; The `push-button' Widget. |
| 1492 | 1493 | ||
| 1493 | (defcustom widget-push-button-gui t | 1494 | ;; (defcustom widget-push-button-gui t |
| 1494 | "If non nil, use GUI push buttons when available." | 1495 | ;; "If non nil, use GUI push buttons when available." |
| 1495 | :group 'widgets | 1496 | ;; :group 'widgets |
| 1496 | :type 'boolean) | 1497 | ;; :type 'boolean) |
| 1497 | 1498 | ||
| 1498 | ;; Cache already created GUI objects. | 1499 | ;; Cache already created GUI objects. |
| 1499 | (defvar widget-push-button-cache nil) | 1500 | ;; (defvar widget-push-button-cache nil) |
| 1500 | 1501 | ||
| 1501 | (defcustom widget-push-button-prefix "[" | 1502 | (defcustom widget-push-button-prefix "[" |
| 1502 | "String used as prefix for buttons." | 1503 | "String used as prefix for buttons." |
| @@ -1521,16 +1522,14 @@ If END is omitted, it defaults to the length of LIST." | |||
| 1521 | (widget-get widget :value))) | 1522 | (widget-get widget :value))) |
| 1522 | (tag-glyph (widget-get widget :tag-glyph)) | 1523 | (tag-glyph (widget-get widget :tag-glyph)) |
| 1523 | (text (concat widget-push-button-prefix | 1524 | (text (concat widget-push-button-prefix |
| 1524 | tag widget-push-button-suffix)) | 1525 | tag widget-push-button-suffix))) |
| 1525 | (gui (cdr (assoc tag widget-push-button-cache)))) | 1526 | (if tag-glyph |
| 1526 | (cond (tag-glyph | 1527 | (widget-image-insert widget text tag-glyph) |
| 1527 | (widget-image-insert widget text tag-glyph)) | 1528 | (insert text)))) |
| 1528 | (t | ||
| 1529 | (insert text))))) | ||
| 1530 | 1529 | ||
| 1531 | (defun widget-gui-action (widget) | 1530 | ;; (defun widget-gui-action (widget) |
| 1532 | "Apply :action for WIDGET." | 1531 | ;; "Apply :action for WIDGET." |
| 1533 | (widget-apply-action widget (this-command-keys))) | 1532 | ;; (widget-apply-action widget (this-command-keys))) |
| 1534 | 1533 | ||
| 1535 | ;;; The `link' Widget. | 1534 | ;;; The `link' Widget. |
| 1536 | 1535 | ||
| @@ -1628,6 +1627,7 @@ If END is omitted, it defaults to the length of LIST." | |||
| 1628 | :convert-widget 'widget-value-convert-widget | 1627 | :convert-widget 'widget-value-convert-widget |
| 1629 | :keymap widget-field-keymap | 1628 | :keymap widget-field-keymap |
| 1630 | :format "%v" | 1629 | :format "%v" |
| 1630 | :help-echo "M-TAB: complete field; RET: enter value" | ||
| 1631 | :value "" | 1631 | :value "" |
| 1632 | :prompt-internal 'widget-field-prompt-internal | 1632 | :prompt-internal 'widget-field-prompt-internal |
| 1633 | :prompt-history 'widget-field-history | 1633 | :prompt-history 'widget-field-history |
| @@ -1652,14 +1652,15 @@ the earlier input." | |||
| 1652 | 1652 | ||
| 1653 | (defun widget-field-prompt-value (widget prompt value unbound) | 1653 | (defun widget-field-prompt-value (widget prompt value unbound) |
| 1654 | "Prompt for a string." | 1654 | "Prompt for a string." |
| 1655 | (let ((initial (if unbound | 1655 | (widget-apply widget |
| 1656 | nil | 1656 | :value-to-external |
| 1657 | (cons (widget-apply widget :value-to-internal | 1657 | (widget-apply widget |
| 1658 | value) 0))) | 1658 | :prompt-internal prompt |
| 1659 | (history (widget-get widget :prompt-history))) | 1659 | (unless unbound |
| 1660 | (let ((answer (widget-apply widget | 1660 | (cons (widget-apply widget |
| 1661 | :prompt-internal prompt initial history))) | 1661 | :value-to-internal value) |
| 1662 | (widget-apply widget :value-to-external answer)))) | 1662 | 0)) |
| 1663 | (widget-get widget :prompt-history)))) | ||
| 1663 | 1664 | ||
| 1664 | (defvar widget-edit-functions nil) | 1665 | (defvar widget-edit-functions nil) |
| 1665 | 1666 | ||
| @@ -1670,12 +1671,9 @@ the earlier input." | |||
| 1670 | 1671 | ||
| 1671 | (defun widget-field-validate (widget) | 1672 | (defun widget-field-validate (widget) |
| 1672 | "Valid if the content matches `:valid-regexp'." | 1673 | "Valid if the content matches `:valid-regexp'." |
| 1673 | (save-excursion | 1674 | (unless (string-match (widget-get widget :valid-regexp) |
| 1674 | (let ((value (widget-apply widget :value-get)) | 1675 | (widget-apply widget :value-get)) |
| 1675 | (regexp (widget-get widget :valid-regexp))) | 1676 | widget)) |
| 1676 | (if (string-match regexp value) | ||
| 1677 | nil | ||
| 1678 | widget)))) | ||
| 1679 | 1677 | ||
| 1680 | (defun widget-field-value-create (widget) | 1678 | (defun widget-field-value-create (widget) |
| 1681 | "Create an editable text field." | 1679 | "Create an editable text field." |
| @@ -1771,9 +1769,8 @@ the earlier input." | |||
| 1771 | (let ((value (widget-get widget :value)) | 1769 | (let ((value (widget-get widget :value)) |
| 1772 | (args (widget-get widget :args)) | 1770 | (args (widget-get widget :args)) |
| 1773 | (explicit (widget-get widget :explicit-choice)) | 1771 | (explicit (widget-get widget :explicit-choice)) |
| 1774 | (explicit-value (widget-get widget :explicit-choice-value)) | ||
| 1775 | current) | 1772 | current) |
| 1776 | (if (and explicit (equal value explicit-value)) | 1773 | (if (and explicit (equal value (widget-get widget :explicit-choice-value))) |
| 1777 | (progn | 1774 | (progn |
| 1778 | ;; If the user specified the choice for this value, | 1775 | ;; If the user specified the choice for this value, |
| 1779 | ;; respect that choice as long as the value is the same. | 1776 | ;; respect that choice as long as the value is the same. |
| @@ -1821,9 +1818,6 @@ when he invoked the menu." | |||
| 1821 | (cond ((not (display-popup-menus-p)) | 1818 | (cond ((not (display-popup-menus-p)) |
| 1822 | ;; No place to pop up a menu. | 1819 | ;; No place to pop up a menu. |
| 1823 | nil) | 1820 | nil) |
| 1824 | ((not (or (fboundp 'x-popup-menu) (fboundp 'popup-menu))) | ||
| 1825 | ;; No way to pop up a menu. | ||
| 1826 | nil) | ||
| 1827 | ((< (length args) 2) | 1821 | ((< (length args) 2) |
| 1828 | ;; Empty or singleton list, just return the value. | 1822 | ;; Empty or singleton list, just return the value. |
| 1829 | nil) | 1823 | nil) |
| @@ -1883,21 +1877,18 @@ when he invoked the menu." | |||
| 1883 | (when this-explicit | 1877 | (when this-explicit |
| 1884 | (widget-put widget :explicit-choice current) | 1878 | (widget-put widget :explicit-choice current) |
| 1885 | (widget-put widget :explicit-choice-value (widget-get widget :value))) | 1879 | (widget-put widget :explicit-choice-value (widget-get widget :value))) |
| 1886 | (let ((value (widget-default-get current))) | 1880 | (widget-value-set |
| 1887 | (widget-value-set widget | 1881 | widget (widget-apply current |
| 1888 | (widget-apply current :value-to-external value))) | 1882 | :value-to-external (widget-default-get current))) |
| 1889 | (widget-setup) | 1883 | (widget-setup) |
| 1890 | (widget-apply widget :notify widget event))) | 1884 | (widget-apply widget :notify widget event))) |
| 1891 | (run-hook-with-args 'widget-edit-functions widget)) | 1885 | (run-hook-with-args 'widget-edit-functions widget)) |
| 1892 | 1886 | ||
| 1893 | (defun widget-choice-validate (widget) | 1887 | (defun widget-choice-validate (widget) |
| 1894 | ;; Valid if we have made a valid choice. | 1888 | ;; Valid if we have made a valid choice. |
| 1895 | (let ((void (widget-get widget :void)) | 1889 | (if (eq (widget-get widget :void) (widget-get widget :choice)) |
| 1896 | (choice (widget-get widget :choice)) | 1890 | widget |
| 1897 | (child (car (widget-get widget :children)))) | 1891 | (widget-apply (car (widget-get widget :children)) :validate))) |
| 1898 | (if (eq void choice) | ||
| 1899 | widget | ||
| 1900 | (widget-apply child :validate)))) | ||
| 1901 | 1892 | ||
| 1902 | (defun widget-choice-match (widget value) | 1893 | (defun widget-choice-match (widget value) |
| 1903 | ;; Matches if one of the choices matches. | 1894 | ;; Matches if one of the choices matches. |
| @@ -2021,8 +2012,8 @@ If the item is checked, CHOSEN is a cons whose cdr is the value." | |||
| 2021 | (goto-char from) | 2012 | (goto-char from) |
| 2022 | ;; Parse % escapes in format. | 2013 | ;; Parse % escapes in format. |
| 2023 | (while (re-search-forward "%\\([bv%]\\)" nil t) | 2014 | (while (re-search-forward "%\\([bv%]\\)" nil t) |
| 2024 | (let ((escape (aref (match-string 1) 0))) | 2015 | (let ((escape (char-after (match-beginning 1)))) |
| 2025 | (replace-match "" t t) | 2016 | (delete-backward-char 2) |
| 2026 | (cond ((eq escape ?%) | 2017 | (cond ((eq escape ?%) |
| 2027 | (insert ?%)) | 2018 | (insert ?%)) |
| 2028 | ((eq escape ?b) | 2019 | ((eq escape ?b) |
| @@ -2205,8 +2196,8 @@ Return an alist of (TYPE MATCH)." | |||
| 2205 | (goto-char from) | 2196 | (goto-char from) |
| 2206 | ;; Parse % escapes in format. | 2197 | ;; Parse % escapes in format. |
| 2207 | (while (re-search-forward "%\\([bv%]\\)" nil t) | 2198 | (while (re-search-forward "%\\([bv%]\\)" nil t) |
| 2208 | (let ((escape (aref (match-string 1) 0))) | 2199 | (let ((escape (char-after (match-beginning 1)))) |
| 2209 | (replace-match "" t t) | 2200 | (delete-backward-char 2) |
| 2210 | (cond ((eq escape ?%) | 2201 | (cond ((eq escape ?%) |
| 2211 | (insert ?%)) | 2202 | (insert ?%)) |
| 2212 | ((eq escape ?b) | 2203 | ((eq escape ?b) |
| @@ -2245,11 +2236,9 @@ Return an alist of (TYPE MATCH)." | |||
| 2245 | (while children | 2236 | (while children |
| 2246 | (setq current (car children) | 2237 | (setq current (car children) |
| 2247 | children (cdr children)) | 2238 | children (cdr children)) |
| 2248 | (let* ((button (widget-get current :button)) | 2239 | (when (widget-apply (widget-get current :button) :value-get) |
| 2249 | (value (widget-apply button :value-get))) | 2240 | (setq found current |
| 2250 | (when value | 2241 | children nil))) |
| 2251 | (setq found current | ||
| 2252 | children nil)))) | ||
| 2253 | found)) | 2242 | found)) |
| 2254 | 2243 | ||
| 2255 | (defun widget-radio-value-inline (widget) | 2244 | (defun widget-radio-value-inline (widget) |
| @@ -2259,11 +2248,9 @@ Return an alist of (TYPE MATCH)." | |||
| 2259 | (while children | 2248 | (while children |
| 2260 | (setq current (car children) | 2249 | (setq current (car children) |
| 2261 | children (cdr children)) | 2250 | children (cdr children)) |
| 2262 | (let* ((button (widget-get current :button)) | 2251 | (when (widget-apply (widget-get current :button) :value-get) |
| 2263 | (value (widget-apply button :value-get))) | 2252 | (setq found (widget-apply current :value-inline) |
| 2264 | (when value | 2253 | children nil))) |
| 2265 | (setq found (widget-apply current :value-inline) | ||
| 2266 | children nil)))) | ||
| 2267 | found)) | 2254 | found)) |
| 2268 | 2255 | ||
| 2269 | (defun widget-radio-value-set (widget value) | 2256 | (defun widget-radio-value-set (widget value) |
| @@ -2346,10 +2333,10 @@ Return an alist of (TYPE MATCH)." | |||
| 2346 | 2333 | ||
| 2347 | ;;; The `editable-list' Widget. | 2334 | ;;; The `editable-list' Widget. |
| 2348 | 2335 | ||
| 2349 | (defcustom widget-editable-list-gui nil | 2336 | ;; (defcustom widget-editable-list-gui nil |
| 2350 | "If non nil, use GUI push-buttons in editable list when available." | 2337 | ;; "If non nil, use GUI push-buttons in editable list when available." |
| 2351 | :type 'boolean | 2338 | ;; :type 'boolean |
| 2352 | :group 'widgets) | 2339 | ;; :group 'widgets) |
| 2353 | 2340 | ||
| 2354 | (define-widget 'editable-list 'default | 2341 | (define-widget 'editable-list 'default |
| 2355 | "A variable list of widgets of the same type." | 2342 | "A variable list of widgets of the same type." |
| @@ -2370,21 +2357,22 @@ Return an alist of (TYPE MATCH)." | |||
| 2370 | 2357 | ||
| 2371 | (defun widget-editable-list-format-handler (widget escape) | 2358 | (defun widget-editable-list-format-handler (widget escape) |
| 2372 | ;; We recognize the insert button. | 2359 | ;; We recognize the insert button. |
| 2373 | (let ((widget-push-button-gui widget-editable-list-gui)) | 2360 | ;;; (let ((widget-push-button-gui widget-editable-list-gui)) |
| 2374 | (cond ((eq escape ?i) | 2361 | (cond ((eq escape ?i) |
| 2375 | (and (widget-get widget :indent) | 2362 | (and (widget-get widget :indent) |
| 2376 | (insert-char ? (widget-get widget :indent))) | 2363 | (insert-char ?\ (widget-get widget :indent))) |
| 2377 | (apply 'widget-create-child-and-convert | 2364 | (apply 'widget-create-child-and-convert |
| 2378 | widget 'insert-button | 2365 | widget 'insert-button |
| 2379 | (widget-get widget :append-button-args))) | 2366 | (widget-get widget :append-button-args))) |
| 2380 | (t | 2367 | (t |
| 2381 | (widget-default-format-handler widget escape))))) | 2368 | (widget-default-format-handler widget escape))) |
| 2369 | ;;; ) | ||
| 2370 | ) | ||
| 2382 | 2371 | ||
| 2383 | (defun widget-editable-list-value-create (widget) | 2372 | (defun widget-editable-list-value-create (widget) |
| 2384 | ;; Insert all values | 2373 | ;; Insert all values |
| 2385 | (let* ((value (widget-get widget :value)) | 2374 | (let* ((value (widget-get widget :value)) |
| 2386 | (type (nth 0 (widget-get widget :args))) | 2375 | (type (nth 0 (widget-get widget :args))) |
| 2387 | (inlinep (widget-get type :inline)) | ||
| 2388 | children) | 2376 | children) |
| 2389 | (widget-put widget :value-pos (copy-marker (point))) | 2377 | (widget-put widget :value-pos (copy-marker (point))) |
| 2390 | (set-marker-insertion-type (widget-get widget :value-pos) t) | 2378 | (set-marker-insertion-type (widget-get widget :value-pos) t) |
| @@ -2393,7 +2381,7 @@ Return an alist of (TYPE MATCH)." | |||
| 2393 | (if answer | 2381 | (if answer |
| 2394 | (setq children (cons (widget-editable-list-entry-create | 2382 | (setq children (cons (widget-editable-list-entry-create |
| 2395 | widget | 2383 | widget |
| 2396 | (if inlinep | 2384 | (if (widget-get type :inline) |
| 2397 | (car answer) | 2385 | (car answer) |
| 2398 | (car (car answer))) | 2386 | (car (car answer))) |
| 2399 | t) | 2387 | t) |
| @@ -2479,17 +2467,17 @@ Return an alist of (TYPE MATCH)." | |||
| 2479 | (defun widget-editable-list-entry-create (widget value conv) | 2467 | (defun widget-editable-list-entry-create (widget value conv) |
| 2480 | ;; Create a new entry to the list. | 2468 | ;; Create a new entry to the list. |
| 2481 | (let ((type (nth 0 (widget-get widget :args))) | 2469 | (let ((type (nth 0 (widget-get widget :args))) |
| 2482 | (widget-push-button-gui widget-editable-list-gui) | 2470 | ;;; (widget-push-button-gui widget-editable-list-gui) |
| 2483 | child delete insert) | 2471 | child delete insert) |
| 2484 | (widget-specify-insert | 2472 | (widget-specify-insert |
| 2485 | (save-excursion | 2473 | (save-excursion |
| 2486 | (and (widget-get widget :indent) | 2474 | (and (widget-get widget :indent) |
| 2487 | (insert-char ? (widget-get widget :indent))) | 2475 | (insert-char ?\ (widget-get widget :indent))) |
| 2488 | (insert (widget-get widget :entry-format))) | 2476 | (insert (widget-get widget :entry-format))) |
| 2489 | ;; Parse % escapes in format. | 2477 | ;; Parse % escapes in format. |
| 2490 | (while (re-search-forward "%\\(.\\)" nil t) | 2478 | (while (re-search-forward "%\\(.\\)" nil t) |
| 2491 | (let ((escape (aref (match-string 1) 0))) | 2479 | (let ((escape (char-after (match-beginning 1)))) |
| 2492 | (replace-match "" t t) | 2480 | (delete-backward-char 2) |
| 2493 | (cond ((eq escape ?%) | 2481 | (cond ((eq escape ?%) |
| 2494 | (insert ?%)) | 2482 | (insert ?%)) |
| 2495 | ((eq escape ?i) | 2483 | ((eq escape ?i) |
| @@ -2514,8 +2502,8 @@ Return an alist of (TYPE MATCH)." | |||
| 2514 | :buttons (cons delete | 2502 | :buttons (cons delete |
| 2515 | (cons insert | 2503 | (cons insert |
| 2516 | (widget-get widget :buttons)))) | 2504 | (widget-get widget :buttons)))) |
| 2517 | (let ((entry-from (copy-marker (point-min))) | 2505 | (let ((entry-from (point-min-marker)) |
| 2518 | (entry-to (copy-marker (point-max)))) | 2506 | (entry-to (point-max-marker))) |
| 2519 | (set-marker-insertion-type entry-from t) | 2507 | (set-marker-insertion-type entry-from t) |
| 2520 | (set-marker-insertion-type entry-to nil) | 2508 | (set-marker-insertion-type entry-to nil) |
| 2521 | (widget-put child :entry-from entry-from) | 2509 | (widget-put child :entry-from entry-from) |
| @@ -2550,13 +2538,13 @@ Return an alist of (TYPE MATCH)." | |||
| 2550 | value (cdr answer)) | 2538 | value (cdr answer)) |
| 2551 | (and (eq (preceding-char) ?\n) | 2539 | (and (eq (preceding-char) ?\n) |
| 2552 | (widget-get widget :indent) | 2540 | (widget-get widget :indent) |
| 2553 | (insert-char ? (widget-get widget :indent))) | 2541 | (insert-char ?\ (widget-get widget :indent))) |
| 2554 | (push (cond ((null answer) | 2542 | (push (cond ((null answer) |
| 2555 | (widget-create-child widget arg)) | 2543 | (widget-create-child widget arg)) |
| 2556 | ((widget-get arg :inline) | 2544 | ((widget-get arg :inline) |
| 2557 | (widget-create-child-value widget arg (car answer))) | 2545 | (widget-create-child-value widget arg (car answer))) |
| 2558 | (t | 2546 | (t |
| 2559 | (widget-create-child-value widget arg (car (car answer))))) | 2547 | (widget-create-child-value widget arg (car (car answer))))) |
| 2560 | children)) | 2548 | children)) |
| 2561 | (widget-put widget :children (nreverse children)))) | 2549 | (widget-put widget :children (nreverse children)))) |
| 2562 | 2550 | ||
| @@ -2667,8 +2655,6 @@ link for that string." | |||
| 2667 | (widget-specify-doc widget from to) | 2655 | (widget-specify-doc widget from to) |
| 2668 | (when widget-documentation-links | 2656 | (when widget-documentation-links |
| 2669 | (let ((regexp widget-documentation-link-regexp) | 2657 | (let ((regexp widget-documentation-link-regexp) |
| 2670 | (predicate widget-documentation-link-p) | ||
| 2671 | (type widget-documentation-link-type) | ||
| 2672 | (buttons (widget-get widget :buttons)) | 2658 | (buttons (widget-get widget :buttons)) |
| 2673 | (widget-mouse-face (default-value 'widget-mouse-face)) | 2659 | (widget-mouse-face (default-value 'widget-mouse-face)) |
| 2674 | (widget-button-face widget-documentation-face) | 2660 | (widget-button-face widget-documentation-face) |
| @@ -2679,8 +2665,9 @@ link for that string." | |||
| 2679 | (let ((name (match-string 1)) | 2665 | (let ((name (match-string 1)) |
| 2680 | (begin (match-beginning 1)) | 2666 | (begin (match-beginning 1)) |
| 2681 | (end (match-end 1))) | 2667 | (end (match-end 1))) |
| 2682 | (when (funcall predicate name) | 2668 | (when (funcall widget-documentation-link-p name) |
| 2683 | (push (widget-convert-button type begin end :value name) | 2669 | (push (widget-convert-button widget-documentation-link-type |
| 2670 | begin end :value name) | ||
| 2684 | buttons))))) | 2671 | buttons))))) |
| 2685 | (widget-put widget :buttons buttons))) | 2672 | (widget-put widget :buttons buttons))) |
| 2686 | (let ((indent (widget-get widget :indent))) | 2673 | (let ((indent (widget-get widget :indent))) |
| @@ -2710,24 +2697,24 @@ link for that string." | |||
| 2710 | (if (string-match "\n" doc) | 2697 | (if (string-match "\n" doc) |
| 2711 | (let ((before (substring doc 0 (match-beginning 0))) | 2698 | (let ((before (substring doc 0 (match-beginning 0))) |
| 2712 | (after (substring doc (match-beginning 0))) | 2699 | (after (substring doc (match-beginning 0))) |
| 2713 | buttons) | 2700 | button) |
| 2714 | (insert before ?\ ) | 2701 | (insert before ?\ ) |
| 2715 | (widget-documentation-link-add widget start (point)) | 2702 | (widget-documentation-link-add widget start (point)) |
| 2716 | (push (widget-create-child-and-convert | 2703 | (setq button |
| 2704 | (widget-create-child-and-convert | ||
| 2717 | widget 'visibility | 2705 | widget 'visibility |
| 2718 | :help-echo "Show or hide rest of the documentation." | 2706 | :help-echo "Show or hide rest of the documentation." |
| 2719 | :off "More" | 2707 | :off "More" |
| 2720 | :always-active t | 2708 | :always-active t |
| 2721 | :action 'widget-parent-action | 2709 | :action 'widget-parent-action |
| 2722 | shown) | 2710 | shown)) |
| 2723 | buttons) | ||
| 2724 | (when shown | 2711 | (when shown |
| 2725 | (setq start (point)) | 2712 | (setq start (point)) |
| 2726 | (when (and indent (not (zerop indent))) | 2713 | (when (and indent (not (zerop indent))) |
| 2727 | (insert-char ?\ indent)) | 2714 | (insert-char ?\ indent)) |
| 2728 | (insert after) | 2715 | (insert after) |
| 2729 | (widget-documentation-link-add widget start (point))) | 2716 | (widget-documentation-link-add widget start (point))) |
| 2730 | (widget-put widget :buttons buttons)) | 2717 | (widget-put widget :buttons (list button))) |
| 2731 | (insert doc) | 2718 | (insert doc) |
| 2732 | (widget-documentation-link-add widget start (point)))) | 2719 | (widget-documentation-link-add widget start (point)))) |
| 2733 | (insert ?\n)) | 2720 | (insert ?\n)) |
| @@ -2803,12 +2790,11 @@ as the value." | |||
| 2803 | 2790 | ||
| 2804 | (defun widget-regexp-validate (widget) | 2791 | (defun widget-regexp-validate (widget) |
| 2805 | "Check that the value of WIDGET is a valid regexp." | 2792 | "Check that the value of WIDGET is a valid regexp." |
| 2806 | (let ((val (widget-value widget))) | 2793 | (condition-case data |
| 2807 | (condition-case data | 2794 | (prog1 nil |
| 2808 | (prog1 nil | 2795 | (string-match (widget-value widget) "")) |
| 2809 | (string-match val "")) | 2796 | (error (widget-put widget :error (error-message-string data)) |
| 2810 | (error (widget-put widget :error (error-message-string data)) | 2797 | widget))) |
| 2811 | widget)))) | ||
| 2812 | 2798 | ||
| 2813 | (define-widget 'file 'string | 2799 | (define-widget 'file 'string |
| 2814 | "A file widget. | 2800 | "A file widget. |
| @@ -2840,10 +2826,10 @@ It will read a file name from the minibuffer when invoked." | |||
| 2840 | (insert (expand-file-name completion directory))) | 2826 | (insert (expand-file-name completion directory))) |
| 2841 | (t | 2827 | (t |
| 2842 | (message "Making completion list...") | 2828 | (message "Making completion list...") |
| 2843 | (let ((list (file-name-all-completions name-part directory))) | 2829 | (with-output-to-temp-buffer "*Completions*" |
| 2844 | (setq list (sort list 'string<)) | 2830 | (display-completion-list |
| 2845 | (with-output-to-temp-buffer "*Completions*" | 2831 | (sort (file-name-all-completions name-part directory) |
| 2846 | (display-completion-list list))) | 2832 | 'string<))) |
| 2847 | (message "Making completion list...%s" "done"))))) | 2833 | (message "Making completion list...%s" "done"))))) |
| 2848 | 2834 | ||
| 2849 | (defun widget-file-prompt-value (widget prompt value unbound) | 2835 | (defun widget-file-prompt-value (widget prompt value unbound) |
| @@ -2912,12 +2898,20 @@ It will read a directory name from the minibuffer when invoked." | |||
| 2912 | 2898 | ||
| 2913 | (define-widget 'function 'sexp | 2899 | (define-widget 'function 'sexp |
| 2914 | "A Lisp function." | 2900 | "A Lisp function." |
| 2915 | :complete-function 'lisp-complete-symbol | 2901 | :complete-function (lambda () |
| 2902 | (interactive) | ||
| 2903 | (lisp-complete-symbol 'fboundp)) | ||
| 2916 | :prompt-value 'widget-field-prompt-value | 2904 | :prompt-value 'widget-field-prompt-value |
| 2917 | :prompt-internal 'widget-symbol-prompt-internal | 2905 | :prompt-internal 'widget-symbol-prompt-internal |
| 2918 | :prompt-match 'fboundp | 2906 | :prompt-match 'fboundp |
| 2919 | :prompt-history 'widget-function-prompt-value-history | 2907 | :prompt-history 'widget-function-prompt-value-history |
| 2920 | :action 'widget-field-action | 2908 | :action 'widget-field-action |
| 2909 | :validate (lambda (widget) | ||
| 2910 | (unless (functionp (widget-value widget)) | ||
| 2911 | (widget-put widget :error (format "Invalid function: %S" | ||
| 2912 | (widget-value widget))) | ||
| 2913 | widget)) | ||
| 2914 | :value 'ignore | ||
| 2921 | :tag "Function") | 2915 | :tag "Function") |
| 2922 | 2916 | ||
| 2923 | (defvar widget-variable-prompt-value-history nil | 2917 | (defvar widget-variable-prompt-value-history nil |
| @@ -2928,6 +2922,9 @@ It will read a directory name from the minibuffer when invoked." | |||
| 2928 | "A Lisp variable." | 2922 | "A Lisp variable." |
| 2929 | :prompt-match 'boundp | 2923 | :prompt-match 'boundp |
| 2930 | :prompt-history 'widget-variable-prompt-value-history | 2924 | :prompt-history 'widget-variable-prompt-value-history |
| 2925 | :complete-function (lambda () | ||
| 2926 | (interactive) | ||
| 2927 | (lisp-complete-symbol 'boundp)) | ||
| 2931 | :tag "Variable") | 2928 | :tag "Variable") |
| 2932 | 2929 | ||
| 2933 | (defvar widget-coding-system-prompt-value-history nil | 2930 | (defvar widget-coding-system-prompt-value-history nil |
| @@ -2937,20 +2934,31 @@ It will read a directory name from the minibuffer when invoked." | |||
| 2937 | "A MULE coding-system." | 2934 | "A MULE coding-system." |
| 2938 | :format "%{%t%}: %v" | 2935 | :format "%{%t%}: %v" |
| 2939 | :tag "Coding system" | 2936 | :tag "Coding system" |
| 2937 | :base-only nil | ||
| 2940 | :prompt-history 'widget-coding-system-prompt-value-history | 2938 | :prompt-history 'widget-coding-system-prompt-value-history |
| 2941 | :prompt-value 'widget-coding-system-prompt-value | 2939 | :prompt-value 'widget-coding-system-prompt-value |
| 2942 | :action 'widget-coding-system-action) | 2940 | :action 'widget-coding-system-action |
| 2943 | 2941 | :complete-function (lambda () | |
| 2942 | (interactive) | ||
| 2943 | (lisp-complete-symbol 'coding-system-p)) | ||
| 2944 | :validate (lambda (widget) | ||
| 2945 | (unless (coding-system-p (widget-value widget)) | ||
| 2946 | (widget-put widget :error (format "Invalid coding system: %S" | ||
| 2947 | (widget-value widget))) | ||
| 2948 | widget)) | ||
| 2949 | :value 'undecided | ||
| 2950 | :prompt-match 'coding-system-p) | ||
| 2951 | |||
| 2944 | (defun widget-coding-system-prompt-value (widget prompt value unbound) | 2952 | (defun widget-coding-system-prompt-value (widget prompt value unbound) |
| 2945 | ;; Read coding-system from minibuffer. | 2953 | "Read coding-system from minibuffer." |
| 2946 | (intern | 2954 | (if (widget-get widget :base-only) |
| 2947 | (completing-read (format "%s (default %s) " prompt value) | 2955 | (intern |
| 2948 | (mapcar (lambda (sym) | 2956 | (completing-read (format "%s (default %s) " prompt value) |
| 2949 | (list (symbol-name sym))) | 2957 | (mapcar #'list (coding-system-list t)) nil nil nil |
| 2950 | (coding-system-list))))) | 2958 | coding-system-history)) |
| 2959 | (read-coding-system (format "%s (default %s) " prompt value) value))) | ||
| 2951 | 2960 | ||
| 2952 | (defun widget-coding-system-action (widget &optional event) | 2961 | (defun widget-coding-system-action (widget &optional event) |
| 2953 | ;; Read a file name from the minibuffer. | ||
| 2954 | (let ((answer | 2962 | (let ((answer |
| 2955 | (widget-coding-system-prompt-value | 2963 | (widget-coding-system-prompt-value |
| 2956 | widget | 2964 | widget |
| @@ -2996,17 +3004,15 @@ It will read a directory name from the minibuffer when invoked." | |||
| 2996 | (skip-syntax-forward "\\s-") | 3004 | (skip-syntax-forward "\\s-") |
| 2997 | (if (eobp) | 3005 | (if (eobp) |
| 2998 | (error "Empty sexp -- use `nil'?")) | 3006 | (error "Empty sexp -- use `nil'?")) |
| 2999 | (let ((value (read (current-buffer)))) | 3007 | (if (eobp) |
| 3000 | (if (eobp) | 3008 | (unless (widget-apply widget :match (read (current-buffer))) |
| 3001 | (if (widget-apply widget :match value) | 3009 | (widget-put widget :error (widget-get widget :type-error)) |
| 3002 | nil | 3010 | widget) |
| 3003 | (widget-put widget :error (widget-get widget :type-error)) | 3011 | (widget-put widget |
| 3004 | widget) | 3012 | :error (format "Junk at end of expression: %s" |
| 3005 | (widget-put widget | 3013 | (buffer-substring (point) |
| 3006 | :error (format "Junk at end of expression: %s" | 3014 | (point-max)))) |
| 3007 | (buffer-substring (point) | 3015 | widget)) |
| 3008 | (point-max)))) | ||
| 3009 | widget))) | ||
| 3010 | (end-of-file ; Avoid confusing error message. | 3016 | (end-of-file ; Avoid confusing error message. |
| 3011 | (widget-put widget :error "Unbalanced sexp") | 3017 | (widget-put widget :error "Unbalanced sexp") |
| 3012 | widget) | 3018 | widget) |
| @@ -3132,12 +3138,10 @@ To use this type, you must define :match or :match-alternatives." | |||
| 3132 | (defun widget-plist-convert-widget (widget) | 3138 | (defun widget-plist-convert-widget (widget) |
| 3133 | ;; Handle `:options'. | 3139 | ;; Handle `:options'. |
| 3134 | (let* ((options (widget-get widget :options)) | 3140 | (let* ((options (widget-get widget :options)) |
| 3135 | (key-type (widget-get widget :key-type)) | ||
| 3136 | (widget-plist-value-type (widget-get widget :value-type)) | ||
| 3137 | (other `(editable-list :inline t | 3141 | (other `(editable-list :inline t |
| 3138 | (group :inline t | 3142 | (group :inline t |
| 3139 | ,key-type | 3143 | ,(widget-get widget :key-type) |
| 3140 | ,widget-plist-value-type))) | 3144 | ,(widget-get widget :value-type)))) |
| 3141 | (args (if options | 3145 | (args (if options |
| 3142 | (list `(checklist :inline t | 3146 | (list `(checklist :inline t |
| 3143 | :greedy t | 3147 | :greedy t |
| @@ -3178,12 +3182,10 @@ To use this type, you must define :match or :match-alternatives." | |||
| 3178 | (defun widget-alist-convert-widget (widget) | 3182 | (defun widget-alist-convert-widget (widget) |
| 3179 | ;; Handle `:options'. | 3183 | ;; Handle `:options'. |
| 3180 | (let* ((options (widget-get widget :options)) | 3184 | (let* ((options (widget-get widget :options)) |
| 3181 | (key-type (widget-get widget :key-type)) | ||
| 3182 | (widget-alist-value-type (widget-get widget :value-type)) | ||
| 3183 | (other `(editable-list :inline t | 3185 | (other `(editable-list :inline t |
| 3184 | (cons :format "%v" | 3186 | (cons :format "%v" |
| 3185 | ,key-type | 3187 | ,(widget-get widget :key-type) |
| 3186 | ,widget-alist-value-type))) | 3188 | ,(widget-get widget :value-type)))) |
| 3187 | (args (if options | 3189 | (args (if options |
| 3188 | (list `(checklist :inline t | 3190 | (list `(checklist :inline t |
| 3189 | :greedy t | 3191 | :greedy t |
| @@ -3220,7 +3222,7 @@ To use this type, you must define :match or :match-alternatives." | |||
| 3220 | (let ((args (widget-get widget :args)) | 3222 | (let ((args (widget-get widget :args)) |
| 3221 | (completion-ignore-case (widget-get widget :case-fold)) | 3223 | (completion-ignore-case (widget-get widget :case-fold)) |
| 3222 | current choices old) | 3224 | current choices old) |
| 3223 | ;; Find the first arg that match VALUE. | 3225 | ;; Find the first arg that matches VALUE. |
| 3224 | (let ((look args)) | 3226 | (let ((look args)) |
| 3225 | (while look | 3227 | (while look |
| 3226 | (if (widget-apply (car look) :match value) | 3228 | (if (widget-apply (car look) :match value) |
| @@ -3316,9 +3318,8 @@ To use this type, you must define :match or :match-alternatives." | |||
| 3316 | (insert-and-inherit (substring completion (length prefix)))) | 3318 | (insert-and-inherit (substring completion (length prefix)))) |
| 3317 | (t | 3319 | (t |
| 3318 | (message "Making completion list...") | 3320 | (message "Making completion list...") |
| 3319 | (let ((list (all-completions prefix list nil))) | 3321 | (with-output-to-temp-buffer "*Completions*" |
| 3320 | (with-output-to-temp-buffer "*Completions*" | 3322 | (display-completion-list (all-completions prefix list nil))) |
| 3321 | (display-completion-list list))) | ||
| 3322 | (message "Making completion list...done"))))) | 3323 | (message "Making completion list...done"))))) |
| 3323 | 3324 | ||
| 3324 | (defun widget-color-sample-face-get (widget) | 3325 | (defun widget-color-sample-face-get (widget) |
| @@ -3356,8 +3357,10 @@ To use this type, you must define :match or :match-alternatives." | |||
| 3356 | 3357 | ||
| 3357 | ;;; The Help Echo | 3358 | ;;; The Help Echo |
| 3358 | 3359 | ||
| 3359 | (defun widget-at (pos) | 3360 | (defun widget-at (&optional pos) |
| 3360 | "The button or field at POS." | 3361 | "The button or field at POS (default, point)." |
| 3362 | (unless pos | ||
| 3363 | (setq pos (point))) | ||
| 3361 | (or (get-char-property pos 'button) | 3364 | (or (get-char-property pos 'button) |
| 3362 | (get-char-property pos 'field))) | 3365 | (get-char-property pos 'field))) |
| 3363 | 3366 | ||
| @@ -3377,7 +3380,9 @@ To use this type, you must define :match or :match-alternatives." | |||
| 3377 | (stringp | 3380 | (stringp |
| 3378 | (setq help-echo | 3381 | (setq help-echo |
| 3379 | (condition-case nil | 3382 | (condition-case nil |
| 3380 | (funcall help-echo (current-buffer) (point)) | 3383 | (funcall help-echo |
| 3384 | (selected-window) (current-buffer) | ||
| 3385 | (point)) | ||
| 3381 | (error (funcall help-echo widget)))))) | 3386 | (error (funcall help-echo widget)))))) |
| 3382 | (stringp (eval help-echo))) | 3387 | (stringp (eval help-echo))) |
| 3383 | (message "%s" help-echo)))) | 3388 | (message "%s" help-echo)))) |