aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorDave Love2000-08-20 18:34:24 +0000
committerDave Love2000-08-20 18:34:24 +0000
commit7fdbdbeadb334686d711f8be3c016ba84b383aa3 (patch)
treeca582e8f9ff94ae654bfa379908b5f72cb92f151
parent35244a0ee5686e923418fefaa5c6c434e135033a (diff)
downloademacs-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.el497
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
177minibuffer." 205minibuffer."
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.
481This is only meaningful for radio buttons or checkboxes in a list." 500This 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.
1220If that does not exists, call the value of `widget-complete-field'." 1222If 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
1441nil 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))))