Mercurial > emacs
comparison lisp/wid-edit.el @ 17550:d6545cfb6c5a
Synched with custom 1.90.
author | Per Abrahamsen <abraham@dina.kvl.dk> |
---|---|
date | Thu, 24 Apr 1997 16:53:55 +0000 |
parents | 8af9d46a055e |
children | 0df9495348e7 |
comparison
equal
deleted
inserted
replaced
17549:f57de209f01b | 17550:d6545cfb6c5a |
---|---|
2 ;; | 2 ;; |
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. |
4 ;; | 4 ;; |
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
6 ;; Keywords: extensions | 6 ;; Keywords: extensions |
7 ;; Version: 1.84 | 7 ;; Version: 1.90 |
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
9 | 9 |
10 ;; This file is part of GNU Emacs. | 10 ;; This file is part of GNU Emacs. |
11 | 11 |
12 ;; GNU Emacs is free software; you can redistribute it and/or modify | 12 ;; GNU Emacs is free software; you can redistribute it and/or modify |
30 | 30 |
31 ;;; Code: | 31 ;;; Code: |
32 | 32 |
33 (require 'widget) | 33 (require 'widget) |
34 | 34 |
35 (eval-when-compile | 35 (eval-when-compile (require 'cl)) |
36 (require 'cl)) | |
37 | 36 |
38 ;;; Compatibility. | 37 ;;; Compatibility. |
39 | 38 |
40 (eval-and-compile | 39 (eval-and-compile |
41 (autoload 'pp-to-string "pp") | 40 (autoload 'pp-to-string "pp") |
73 | 72 |
74 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) | 73 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) |
75 ;; We have the old custom-library, hack around it! | 74 ;; We have the old custom-library, hack around it! |
76 (defmacro defgroup (&rest args) nil) | 75 (defmacro defgroup (&rest args) nil) |
77 (defmacro defcustom (var value doc &rest args) | 76 (defmacro defcustom (var value doc &rest args) |
78 `(defvar ,var ,value ,doc)) | 77 (` (defvar (, var) (, value) (, doc)))) |
79 (defmacro defface (&rest args) nil) | 78 (defmacro defface (&rest args) nil) |
80 (define-widget-keywords :prefix :tag :load :link :options :type :group) | 79 (define-widget-keywords :prefix :tag :load :link :options :type :group) |
81 (when (fboundp 'copy-face) | 80 (when (fboundp 'copy-face) |
82 (copy-face 'default 'widget-documentation-face) | 81 (copy-face 'default 'widget-documentation-face) |
83 (copy-face 'bold 'widget-button-face) | 82 (copy-face 'bold 'widget-button-face) |
132 :type 'face | 131 :type 'face |
133 :group 'widgets) | 132 :group 'widgets) |
134 | 133 |
135 (defface widget-field-face '((((class grayscale color) | 134 (defface widget-field-face '((((class grayscale color) |
136 (background light)) | 135 (background light)) |
137 (:background "light gray")) | 136 (:background "gray85")) |
138 (((class grayscale color) | 137 (((class grayscale color) |
139 (background dark)) | 138 (background dark)) |
140 (:background "dark gray")) | 139 (:background "dark gray")) |
141 (t | 140 (t |
142 (:italic t))) | 141 (:italic t))) |
182 | 181 |
183 (defun widget-choose (title items &optional event) | 182 (defun widget-choose (title items &optional event) |
184 "Choose an item from a list. | 183 "Choose an item from a list. |
185 | 184 |
186 First argument TITLE is the name of the list. | 185 First argument TITLE is the name of the list. |
187 Second argument ITEMS is an alist (NAME . VALUE). | 186 Second argument ITEMS is an list whose members are either |
187 (NAME . VALUE), to indicate selectable items, or just strings to | |
188 indicate unselectable items. | |
188 Optional third argument EVENT is an input event. | 189 Optional third argument EVENT is an input event. |
189 | 190 |
190 The user is asked to choose between each NAME from the items alist, | 191 The user is asked to choose between each NAME from the items alist, |
191 and the VALUE of the chosen element will be returned. If EVENT is a | 192 and the VALUE of the chosen element will be returned. If EVENT is a |
192 mouse event, and the number of elements in items is less than | 193 mouse event, and the number of elements in items is less than |
203 (let ((val (get-popup-menu-response | 204 (let ((val (get-popup-menu-response |
204 (cons title | 205 (cons title |
205 (mapcar | 206 (mapcar |
206 (function | 207 (function |
207 (lambda (x) | 208 (lambda (x) |
208 (vector (car x) (list (car x)) t))) | 209 (if (stringp x) |
210 (vector x nil nil) | |
211 (vector (car x) (list (car x)) t)))) | |
209 items))))) | 212 items))))) |
210 (setq val (and val | 213 (setq val (and val |
211 (listp (event-object val)) | 214 (listp (event-object val)) |
212 (stringp (car-safe (event-object val))) | 215 (stringp (car-safe (event-object val))) |
213 (car (event-object val)))) | 216 (car (event-object val)))) |
214 (cdr (assoc val items)))) | 217 (cdr (assoc val items)))) |
215 (t | 218 (t |
219 (setq items (remove-if 'stringp items)) | |
216 (let ((val (completing-read (concat title ": ") items nil t))) | 220 (let ((val (completing-read (concat title ": ") items nil t))) |
217 (if (stringp val) | 221 (if (stringp val) |
218 (let ((try (try-completion val items))) | 222 (let ((try (try-completion val items))) |
219 (when (stringp try) | 223 (when (stringp try) |
220 (setq val try)) | 224 (setq val try)) |
232 (setq child (car children) | 236 (setq child (car children) |
233 children (cdr children)) | 237 children (cdr children)) |
234 (when (eq (widget-get child :button) widget) | 238 (when (eq (widget-get child :button) widget) |
235 (throw 'child child))) | 239 (throw 'child child))) |
236 nil))) | 240 nil))) |
241 | |
242 ;;; Helper functions. | |
243 ;; | |
244 ;; These are widget specific. | |
245 | |
246 ;;;###autoload | |
247 (defun widget-prompt-value (widget prompt &optional value unbound) | |
248 "Prompt for a value matching WIDGET, using PROMPT. | |
249 The current value is assumed to be VALUE, unless UNBOUND is non-nil." | |
250 (unless (listp widget) | |
251 (setq widget (list widget))) | |
252 (setq widget (widget-convert widget)) | |
253 (let ((answer (widget-apply widget :prompt-value prompt value unbound))) | |
254 (unless (widget-apply widget :match answer) | |
255 (error "Value does not match %S type." (car widget))) | |
256 answer)) | |
237 | 257 |
238 ;;; Widget text specifications. | 258 ;;; Widget text specifications. |
239 ;; | 259 ;; |
240 ;; These functions are for specifying text properties. | 260 ;; These functions are for specifying text properties. |
241 | 261 |
386 (add-text-properties from to (list 'widget-doc widget | 406 (add-text-properties from to (list 'widget-doc widget |
387 'face 'widget-documentation-face))) | 407 'face 'widget-documentation-face))) |
388 | 408 |
389 (defmacro widget-specify-insert (&rest form) | 409 (defmacro widget-specify-insert (&rest form) |
390 ;; Execute FORM without inheriting any text properties. | 410 ;; Execute FORM without inheriting any text properties. |
391 `(save-restriction | 411 (` |
412 (save-restriction | |
392 (let ((inhibit-read-only t) | 413 (let ((inhibit-read-only t) |
393 result | 414 result |
394 after-change-functions) | 415 after-change-functions) |
395 (insert "<>") | 416 (insert "<>") |
396 (narrow-to-region (- (point) 2) (point)) | 417 (narrow-to-region (- (point) 2) (point)) |
397 (widget-specify-none (point-min) (point-max)) | 418 (widget-specify-none (point-min) (point-max)) |
398 (goto-char (1+ (point-min))) | 419 (goto-char (1+ (point-min))) |
399 (setq result (progn ,@form)) | 420 (setq result (progn (,@ form))) |
400 (delete-region (point-min) (1+ (point-min))) | 421 (delete-region (point-min) (1+ (point-min))) |
401 (delete-region (1- (point-max)) (point-max)) | 422 (delete-region (1- (point-max)) (point-max)) |
402 (goto-char (point-max)) | 423 (goto-char (point-max)) |
403 result))) | 424 result)))) |
404 | 425 |
405 (defface widget-inactive-face '((((class grayscale color) | 426 (defface widget-inactive-face '((((class grayscale color) |
406 (background dark)) | 427 (background dark)) |
407 (:foreground "light gray")) | 428 (:foreground "light gray")) |
408 (((class grayscale color) | 429 (((class grayscale color) |
416 (defun widget-specify-inactive (widget from to) | 437 (defun widget-specify-inactive (widget from to) |
417 "Make WIDGET inactive for user modifications." | 438 "Make WIDGET inactive for user modifications." |
418 (unless (widget-get widget :inactive) | 439 (unless (widget-get widget :inactive) |
419 (let ((overlay (make-overlay from to nil t nil))) | 440 (let ((overlay (make-overlay from to nil t nil))) |
420 (overlay-put overlay 'face 'widget-inactive-face) | 441 (overlay-put overlay 'face 'widget-inactive-face) |
421 (overlay-put overlay 'evaporate 't) | 442 (overlay-put overlay 'evaporate t) |
443 (overlay-put overlay 'priority 100) | |
422 (overlay-put overlay (if (string-match "XEmacs" emacs-version) | 444 (overlay-put overlay (if (string-match "XEmacs" emacs-version) |
423 'read-only | 445 'read-only |
424 'modification-hooks) '(widget-overlay-inactive)) | 446 'modification-hooks) '(widget-overlay-inactive)) |
425 (widget-put widget :inactive overlay)))) | 447 (widget-put widget :inactive overlay)))) |
426 | 448 |
501 (defun widget-apply-action (widget &optional event) | 523 (defun widget-apply-action (widget &optional event) |
502 "Apply :action in WIDGET in response to EVENT." | 524 "Apply :action in WIDGET in response to EVENT." |
503 (if (widget-apply widget :active) | 525 (if (widget-apply widget :active) |
504 (widget-apply widget :action event) | 526 (widget-apply widget :action event) |
505 (error "Attempt to perform action on inactive widget"))) | 527 (error "Attempt to perform action on inactive widget"))) |
506 | 528 |
507 ;;; Glyphs. | 529 ;;; Glyphs. |
508 | 530 |
509 (defcustom widget-glyph-directory (concat data-directory "custom/") | 531 (defcustom widget-glyph-directory (concat data-directory "custom/") |
510 "Where widget glyphs are located. | 532 "Where widget glyphs are located. |
511 If this variable is nil, widget will try to locate the directory | 533 If this variable is nil, widget will try to locate the directory |
798 (button (goto-char button)) | 820 (button (goto-char button)) |
799 (field (goto-char field)) | 821 (field (goto-char field)) |
800 (t | 822 (t |
801 (error "No buttons or fields found")))))) | 823 (error "No buttons or fields found")))))) |
802 (setq button (widget-at (point))) | 824 (setq button (widget-at (point))) |
803 (if (and button (widget-get button :tab-order) | 825 (if (or (and button (widget-get button :tab-order) |
804 (< (widget-get button :tab-order) 0)) | 826 (< (widget-get button :tab-order) 0)) |
827 (and button (not (widget-apply button :active)))) | |
805 (setq arg (1+ arg)))))) | 828 (setq arg (1+ arg)))))) |
806 (while (< arg 0) | 829 (while (< arg 0) |
807 (if (= (point-min) (point)) | 830 (if (= (point-min) (point)) |
808 (forward-char 1)) | 831 (forward-char 1)) |
809 (setq arg (1+ arg)) | 832 (setq arg (1+ arg)) |
836 (cond ((and button field) | 859 (cond ((and button field) |
837 (goto-char (max button field))) | 860 (goto-char (max button field))) |
838 (button (goto-char button)) | 861 (button (goto-char button)) |
839 (field (goto-char field))) | 862 (field (goto-char field))) |
840 (setq button (widget-at (point))) | 863 (setq button (widget-at (point))) |
841 (if (and button (widget-get button :tab-order) | 864 (if (or (and button (widget-get button :tab-order) |
842 (< (widget-get button :tab-order) 0)) | 865 (< (widget-get button :tab-order) 0)) |
866 (and button (not (widget-apply button :active)))) | |
843 (setq arg (1- arg))))) | 867 (setq arg (1- arg))))) |
844 (widget-echo-help (point)) | 868 (widget-echo-help (point)) |
845 (run-hooks 'widget-move-hook)) | 869 (run-hooks 'widget-move-hook)) |
846 | 870 |
847 (defun widget-forward (arg) | 871 (defun widget-forward (arg) |
1014 :validate (lambda (widget) nil) | 1038 :validate (lambda (widget) nil) |
1015 :active 'widget-default-active | 1039 :active 'widget-default-active |
1016 :activate 'widget-specify-active | 1040 :activate 'widget-specify-active |
1017 :deactivate 'widget-default-deactivate | 1041 :deactivate 'widget-default-deactivate |
1018 :action 'widget-default-action | 1042 :action 'widget-default-action |
1019 :notify 'widget-default-notify) | 1043 :notify 'widget-default-notify |
1044 :prompt-value 'widget-default-prompt-value) | |
1020 | 1045 |
1021 (defun widget-default-create (widget) | 1046 (defun widget-default-create (widget) |
1022 "Create WIDGET at point in the current buffer." | 1047 "Create WIDGET at point in the current buffer." |
1023 (widget-specify-insert | 1048 (widget-specify-insert |
1024 (let ((from (point)) | 1049 (let ((from (point)) |
1085 (to (copy-marker (point-max)))) | 1110 (to (copy-marker (point-max)))) |
1086 (widget-specify-text from to) | 1111 (widget-specify-text from to) |
1087 (set-marker-insertion-type from t) | 1112 (set-marker-insertion-type from t) |
1088 (set-marker-insertion-type to nil) | 1113 (set-marker-insertion-type to nil) |
1089 (widget-put widget :from from) | 1114 (widget-put widget :from from) |
1090 (widget-put widget :to to)))) | 1115 (widget-put widget :to to))) |
1116 (widget-clear-undo)) | |
1091 | 1117 |
1092 (defun widget-default-format-handler (widget escape) | 1118 (defun widget-default-format-handler (widget escape) |
1093 ;; We recognize the %h escape by default. | 1119 ;; We recognize the %h escape by default. |
1094 (let* ((buttons (widget-get widget :buttons)) | 1120 (let* ((buttons (widget-get widget :buttons)) |
1095 (doc-property (widget-get widget :documentation-property)) | 1121 (doc-property (widget-get widget :documentation-property)) |
1147 (widget-apply widget :value-delete) | 1173 (widget-apply widget :value-delete) |
1148 (when (< from to) | 1174 (when (< from to) |
1149 ;; Kludge: this doesn't need to be true for empty formats. | 1175 ;; Kludge: this doesn't need to be true for empty formats. |
1150 (delete-region from to)) | 1176 (delete-region from to)) |
1151 (set-marker from nil) | 1177 (set-marker from nil) |
1152 (set-marker to nil))) | 1178 (set-marker to nil)) |
1179 (widget-clear-undo)) | |
1153 | 1180 |
1154 (defun widget-default-value-set (widget value) | 1181 (defun widget-default-value-set (widget value) |
1155 ;; Recreate widget with new value. | 1182 ;; Recreate widget with new value. |
1156 (save-excursion | 1183 (save-excursion |
1157 (goto-char (widget-get widget :from)) | 1184 (goto-char (widget-get widget :from)) |
1191 (widget-apply parent :notify widget event)))) | 1218 (widget-apply parent :notify widget event)))) |
1192 | 1219 |
1193 (defun widget-default-notify (widget child &optional event) | 1220 (defun widget-default-notify (widget child &optional event) |
1194 ;; Pass notification to parent. | 1221 ;; Pass notification to parent. |
1195 (widget-default-action widget event)) | 1222 (widget-default-action widget event)) |
1223 | |
1224 (defun widget-default-prompt-value (widget prompt value unbound) | |
1225 ;; Read an arbitrary value. Stolen from `set-variable'. | |
1226 ;; (let ((initial (if unbound | |
1227 ;; nil | |
1228 ;; ;; It would be nice if we could do a `(cons val 1)' here. | |
1229 ;; (prin1-to-string (custom-quote value)))))) | |
1230 (eval-minibuffer prompt )) | |
1196 | 1231 |
1197 ;;; The `item' Widget. | 1232 ;;; The `item' Widget. |
1198 | 1233 |
1199 (define-widget 'item 'default | 1234 (define-widget 'item 'default |
1200 "Constant items for inclusion in other widgets." | 1235 "Constant items for inclusion in other widgets." |
1295 "A link to an info file." | 1330 "A link to an info file." |
1296 :action 'widget-info-link-action) | 1331 :action 'widget-info-link-action) |
1297 | 1332 |
1298 (defun widget-info-link-action (widget &optional event) | 1333 (defun widget-info-link-action (widget &optional event) |
1299 "Open the info node specified by WIDGET." | 1334 "Open the info node specified by WIDGET." |
1300 (Info-goto-node (widget-value widget))) | 1335 (Info-goto-node (widget-value widget)) |
1336 ;; Steal button release event. | |
1337 (if (and (fboundp 'button-press-event-p) | |
1338 (fboundp 'next-command-event)) | |
1339 ;; XEmacs | |
1340 (and event | |
1341 (button-press-event-p event) | |
1342 (next-command-event)) | |
1343 ;; Emacs | |
1344 (when (memq 'down (event-modifiers event)) | |
1345 (read-event)))) | |
1301 | 1346 |
1302 ;;; The `url-link' Widget. | 1347 ;;; The `url-link' Widget. |
1303 | 1348 |
1304 (define-widget 'url-link 'link | 1349 (define-widget 'url-link 'link |
1305 "A link to an www page." | 1350 "A link to an www page." |
1505 (widget-choose tag (reverse choices) event)))) | 1550 (widget-choose tag (reverse choices) event)))) |
1506 (when current | 1551 (when current |
1507 (widget-value-set widget | 1552 (widget-value-set widget |
1508 (widget-apply current :value-to-external | 1553 (widget-apply current :value-to-external |
1509 (widget-get current :value))) | 1554 (widget-get current :value))) |
1510 (widget-apply widget :notify widget event) | 1555 (widget-apply widget :notify widget event) |
1511 (widget-setup))) | 1556 (widget-setup)))) |
1512 ;; Notify parent. | |
1513 (widget-apply widget :notify widget event) | |
1514 (widget-clear-undo)) | |
1515 | 1557 |
1516 (defun widget-choice-validate (widget) | 1558 (defun widget-choice-validate (widget) |
1517 ;; Valid if we have made a valid choice. | 1559 ;; Valid if we have made a valid choice. |
1518 (let ((void (widget-get widget :void)) | 1560 (let ((void (widget-get widget :void)) |
1519 (choice (widget-get widget :choice)) | 1561 (choice (widget-get widget :choice)) |
1565 | 1607 |
1566 (defun widget-toggle-action (widget &optional event) | 1608 (defun widget-toggle-action (widget &optional event) |
1567 ;; Toggle value. | 1609 ;; Toggle value. |
1568 (widget-value-set widget (not (widget-value widget))) | 1610 (widget-value-set widget (not (widget-value widget))) |
1569 (widget-apply widget :notify widget event)) | 1611 (widget-apply widget :notify widget event)) |
1570 | 1612 |
1571 ;;; The `checkbox' Widget. | 1613 ;;; The `checkbox' Widget. |
1572 | 1614 |
1573 (define-widget 'checkbox 'toggle | 1615 (define-widget 'checkbox 'toggle |
1574 "A checkbox toggle." | 1616 "A checkbox toggle." |
1575 :format "%[%v%]" | 1617 :format "%[%v%]" |
2220 | 2262 |
2221 ;;; The Sexp Widgets. | 2263 ;;; The Sexp Widgets. |
2222 | 2264 |
2223 (define-widget 'const 'item | 2265 (define-widget 'const 'item |
2224 "An immutable sexp." | 2266 "An immutable sexp." |
2267 :prompt-value 'widget-const-prompt-value | |
2225 :format "%t\n%d") | 2268 :format "%t\n%d") |
2226 | 2269 |
2227 (define-widget 'function-item 'item | 2270 (defun widget-const-prompt-value (widget prompt value unbound) |
2271 ;; Return the value of the const. | |
2272 (widget-value widget)) | |
2273 | |
2274 (define-widget 'function-item 'const | |
2228 "An immutable function name." | 2275 "An immutable function name." |
2229 :format "%v\n%h" | 2276 :format "%v\n%h" |
2230 :documentation-property (lambda (symbol) | 2277 :documentation-property (lambda (symbol) |
2231 (condition-case nil | 2278 (condition-case nil |
2232 (documentation symbol t) | 2279 (documentation symbol t) |
2233 (error nil)))) | 2280 (error nil)))) |
2234 | 2281 |
2235 (define-widget 'variable-item 'item | 2282 (define-widget 'variable-item 'const |
2236 "An immutable variable name." | 2283 "An immutable variable name." |
2237 :format "%v\n%h" | 2284 :format "%v\n%h" |
2238 :documentation-property 'variable-documentation) | 2285 :documentation-property 'variable-documentation) |
2239 | 2286 |
2240 (define-widget 'string 'editable-field | 2287 (define-widget 'string 'editable-field |
2241 "A string" | 2288 "A string" |
2289 :prompt-value 'widget-string-prompt-value | |
2242 :tag "String" | 2290 :tag "String" |
2243 :format "%[%t%]: %v") | 2291 :format "%[%t%]: %v") |
2244 | 2292 |
2293 (defvar widget-string-prompt-value-history nil | |
2294 "History of input to `widget-string-prompt-value'.") | |
2295 | |
2296 (defun widget-string-prompt-value (widget prompt value unbound) | |
2297 ;; Read a string. | |
2298 (read-string prompt (if unbound nil (cons value 1)) | |
2299 'widget-string-prompt-value-history)) | |
2300 | |
2245 (define-widget 'regexp 'string | 2301 (define-widget 'regexp 'string |
2246 "A regular expression." | 2302 "A regular expression." |
2247 ;; Should do validation. | 2303 :match 'widget-regexp-match |
2304 :validate 'widget-regexp-validate | |
2248 :tag "Regexp") | 2305 :tag "Regexp") |
2306 | |
2307 (defun widget-regexp-match (widget value) | |
2308 ;; Match valid regexps. | |
2309 (and (stringp value) | |
2310 (condition-case data | |
2311 (prog1 t | |
2312 (string-match value "")) | |
2313 (error nil)))) | |
2314 | |
2315 (defun widget-regexp-validate (widget) | |
2316 "Check that the value of WIDGET is a valid regexp." | |
2317 (let ((val (widget-value widget))) | |
2318 (condition-case data | |
2319 (prog1 nil | |
2320 (string-match val "")) | |
2321 (error (widget-put widget :error (error-message-string data)) | |
2322 widget)))) | |
2249 | 2323 |
2250 (define-widget 'file 'string | 2324 (define-widget 'file 'string |
2251 "A file widget. | 2325 "A file widget. |
2252 It will read a file name from the minibuffer when activated." | 2326 It will read a file name from the minibuffer when activated." |
2327 :prompt-value 'widget-file-prompt-value | |
2253 :format "%[%t%]: %v" | 2328 :format "%[%t%]: %v" |
2254 :tag "File" | 2329 :tag "File" |
2255 :action 'widget-file-action) | 2330 :action 'widget-file-action) |
2331 | |
2332 (defun widget-file-prompt-value (widget prompt value unbound) | |
2333 ;; Read file from minibuffer. | |
2334 (abbreviate-file-name | |
2335 (if unbound | |
2336 (read-file-name prompt) | |
2337 (let ((prompt2 (concat prompt "(default `" value "') ")) | |
2338 (dir (file-name-directory value)) | |
2339 (file (file-name-nondirectory value)) | |
2340 (must-match (widget-get widget :must-match))) | |
2341 (read-file-name prompt2 dir nil must-match file))))) | |
2256 | 2342 |
2257 (defun widget-file-action (widget &optional event) | 2343 (defun widget-file-action (widget &optional event) |
2258 ;; Read a file name from the minibuffer. | 2344 ;; Read a file name from the minibuffer. |
2259 (let* ((value (widget-value widget)) | 2345 (let* ((value (widget-value widget)) |
2260 (dir (file-name-directory value)) | 2346 (dir (file-name-directory value)) |
2301 :tag "Lisp expression" | 2387 :tag "Lisp expression" |
2302 :value nil | 2388 :value nil |
2303 :validate 'widget-sexp-validate | 2389 :validate 'widget-sexp-validate |
2304 :match (lambda (widget value) t) | 2390 :match (lambda (widget value) t) |
2305 :value-to-internal 'widget-sexp-value-to-internal | 2391 :value-to-internal 'widget-sexp-value-to-internal |
2306 :value-to-external (lambda (widget value) (read value))) | 2392 :value-to-external (lambda (widget value) (read value)) |
2393 :prompt-value 'widget-sexp-prompt-value) | |
2307 | 2394 |
2308 (defun widget-sexp-value-to-internal (widget value) | 2395 (defun widget-sexp-value-to-internal (widget value) |
2309 ;; Use pp for printer representation. | 2396 ;; Use pp for printer representation. |
2310 (let ((pp (pp-to-string value))) | 2397 (let ((pp (pp-to-string value))) |
2311 (while (string-match "\n\\'" pp) | 2398 (while (string-match "\n\\'" pp) |
2335 (point-max)))) | 2422 (point-max)))) |
2336 widget)) | 2423 widget)) |
2337 (error (widget-put widget :error (error-message-string data)) | 2424 (error (widget-put widget :error (error-message-string data)) |
2338 widget))))) | 2425 widget))))) |
2339 | 2426 |
2427 (defvar widget-sexp-prompt-value-history nil | |
2428 "History of input to `widget-sexp-prompt-value'.") | |
2429 | |
2430 (defun widget-sexp-prompt-value (widget prompt value unbound) | |
2431 ;; Read an arbitrary sexp. | |
2432 (let ((found (read-string prompt | |
2433 (if unbound nil (cons (prin1-to-string value) 1)) | |
2434 'widget-sexp-prompt-value))) | |
2435 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) | |
2436 (erase-buffer) | |
2437 (insert found) | |
2438 (goto-char (point-min)) | |
2439 (let ((answer (read buffer))) | |
2440 (unless (eobp) | |
2441 (error "Junk at end of expression: %s" | |
2442 (buffer-substring (point) (point-max)))) | |
2443 answer)))) | |
2444 | |
2340 (define-widget 'integer 'sexp | 2445 (define-widget 'integer 'sexp |
2341 "An integer." | 2446 "An integer." |
2342 :tag "Integer" | 2447 :tag "Integer" |
2343 :value 0 | 2448 :value 0 |
2344 :type-error "This field should contain an integer" | 2449 :type-error "This field should contain an integer" |
2352 "An character." | 2457 "An character." |
2353 :tag "Character" | 2458 :tag "Character" |
2354 :value 0 | 2459 :value 0 |
2355 :size 1 | 2460 :size 1 |
2356 :format "%{%t%}: %v\n" | 2461 :format "%{%t%}: %v\n" |
2357 :type-error "This field should contain a character" | 2462 :valid-regexp "\\`.\\'" |
2463 :error "This field should contain a single character" | |
2358 :value-to-internal (lambda (widget value) | 2464 :value-to-internal (lambda (widget value) |
2359 (if (integerp value) | 2465 (if (integerp value) |
2360 (char-to-string value) | 2466 (char-to-string value) |
2361 value)) | 2467 value)) |
2362 :value-to-external (lambda (widget value) | 2468 :value-to-external (lambda (widget value) |
2430 :format "%{%t%}:\n%v") | 2536 :format "%{%t%}:\n%v") |
2431 | 2537 |
2432 (define-widget 'boolean 'toggle | 2538 (define-widget 'boolean 'toggle |
2433 "To be nil or non-nil, that is the question." | 2539 "To be nil or non-nil, that is the question." |
2434 :tag "Boolean" | 2540 :tag "Boolean" |
2541 :prompt-value 'widget-boolean-prompt-value | |
2435 :format "%{%t%}: %[%v%]\n") | 2542 :format "%{%t%}: %[%v%]\n") |
2543 | |
2544 (defun widget-boolean-prompt-value (widget prompt value unbound) | |
2545 ;; Toggle a boolean. | |
2546 (cond (unbound | |
2547 (y-or-n-p prompt)) | |
2548 (value | |
2549 (message "Off") | |
2550 nil) | |
2551 (t | |
2552 (message "On") | |
2553 t))) | |
2436 | 2554 |
2437 ;;; The `color' Widget. | 2555 ;;; The `color' Widget. |
2438 | 2556 |
2439 (define-widget 'color-item 'choice-item | 2557 (define-widget 'color-item 'choice-item |
2440 "A color name (with sample)." | 2558 "A color name (with sample)." |