Mercurial > emacs
annotate lisp/wid-edit.el @ 24419:30e478cd167e
(shell-command-default-error-buffer): Renamed from
shell-command-on-region-default-error-buffer.
(shell-command-on-region): Mention in echo area when there
is some error output. Mention success or failure, too.
Accumulate multiple error outputs
going forward, with formfeed in between. Display the error buffer
when we have put something in it.
(shell-command): Add the ERROR-BUFFER argument feature.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Mon, 01 Mar 1999 03:19:32 +0000 |
parents | 971fec299b71 |
children | 731dcf8c11dc |
rev | line source |
---|---|
17334 | 1 ;;; wid-edit.el --- Functions for creating and using widgets. |
2 ;; | |
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. | |
4 ;; | |
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | |
6 ;; Keywords: extensions | |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
7 ;; Version: 1.9951 |
17334 | 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
9 | |
17535
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
10 ;; This file is part of GNU Emacs. |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
11 |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
12 ;; GNU Emacs is free software; you can redistribute it and/or modify |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
13 ;; it under the terms of the GNU General Public License as published by |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
14 ;; the Free Software Foundation; either version 2, or (at your option) |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
15 ;; any later version. |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
16 |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
17 ;; GNU Emacs is distributed in the hope that it will be useful, |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
20 ;; GNU General Public License for more details. |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
21 |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
22 ;; You should have received a copy of the GNU General Public License |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
25 ;; Boston, MA 02111-1307, USA. |
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
26 |
17334 | 27 ;;; Commentary: |
28 ;; | |
29 ;; See `widget.el'. | |
30 | |
31 ;;; Code: | |
32 | |
33 (require 'widget) | |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
34 (eval-when-compile (require 'cl)) |
17334 | 35 |
36 ;;; Compatibility. | |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
37 |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
38 (defun widget-event-point (event) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
39 "Character position of the end of event if that exists, or nil." |
21338
f94e2fdb6617
(widget-beginning-of-line): Don't set zmacs-region-stays.
Richard M. Stallman <rms@gnu.org>
parents:
21337
diff
changeset
|
40 (posn-point (event-end event))) |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
41 |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
42 (defalias 'widget-read-event 'read-event) |
17334 | 43 |
44 (eval-and-compile | |
45 (autoload 'pp-to-string "pp") | |
46 (autoload 'Info-goto-node "info") | |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
47 (autoload 'finder-commentary "finder" nil t) |
17334 | 48 |
49 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) | |
50 ;; We have the old custom-library, hack around it! | |
51 (defmacro defgroup (&rest args) nil) | |
52 (defmacro defcustom (var value doc &rest args) | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
53 (` (defvar (, var) (, value) (, doc)))) |
17334 | 54 (defmacro defface (&rest args) nil) |
55 (define-widget-keywords :prefix :tag :load :link :options :type :group) | |
56 (when (fboundp 'copy-face) | |
57 (copy-face 'default 'widget-documentation-face) | |
58 (copy-face 'bold 'widget-button-face) | |
59 (copy-face 'italic 'widget-field-face))) | |
60 | |
17799 | 61 (unless (fboundp 'button-release-event-p) |
62 ;; XEmacs function missing from Emacs. | |
63 (defun button-release-event-p (event) | |
64 "Non-nil if EVENT is a mouse-button-release event object." | |
65 (and (eventp event) | |
66 (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3)) | |
67 (or (memq 'click (event-modifiers event)) | |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
68 (memq 'drag (event-modifiers event))))))) |
17334 | 69 |
70 ;;; Customization. | |
71 | |
72 (defgroup widgets nil | |
73 "Customization support for the Widget Library." | |
74 :link '(custom-manual "(widget)Top") | |
75 :link '(url-link :tag "Development Page" | |
76 "http://www.dina.kvl.dk/~abraham/custom/") | |
18598
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
77 :link '(emacs-library-link :tag "Lisp File" "widget.el") |
17334 | 78 :prefix "widget-" |
79 :group 'extensions | |
80 :group 'hypermedia) | |
81 | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
82 (defgroup widget-documentation nil |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
83 "Options controling the display of documentation strings." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
84 :group 'widgets) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
85 |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
86 (defgroup widget-faces nil |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
87 "Faces used by the widget library." |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
88 :group 'widgets |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
89 :group 'faces) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
90 |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
91 (defvar widget-documentation-face 'widget-documentation-face |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
92 "Face used for documentation strings in widges. |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
93 This exists as a variable so it can be set locally in certain buffers.") |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
94 |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
95 (defface widget-documentation-face '((((class color) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
96 (background dark)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
97 (:foreground "lime green")) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
98 (((class color) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
99 (background light)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
100 (:foreground "dark green")) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
101 (t nil)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
102 "Face used for documentation text." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
103 :group 'widget-documentation |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
104 :group 'widget-faces) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
105 |
18572
f0c2a091d91f
(color-sample, editable-color): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
18562
diff
changeset
|
106 (defvar widget-button-face 'widget-button-face |
f0c2a091d91f
(color-sample, editable-color): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
18562
diff
changeset
|
107 "Face used for buttons in widges. |
f0c2a091d91f
(color-sample, editable-color): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
18562
diff
changeset
|
108 This exists as a variable so it can be set locally in certain buffers.") |
f0c2a091d91f
(color-sample, editable-color): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
18562
diff
changeset
|
109 |
17334 | 110 (defface widget-button-face '((t (:bold t))) |
111 "Face used for widget buttons." | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
112 :group 'widget-faces) |
17334 | 113 |
114 (defcustom widget-mouse-face 'highlight | |
115 "Face used for widget buttons when the mouse is above them." | |
116 :type 'face | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
117 :group 'widget-faces) |
17334 | 118 |
119 (defface widget-field-face '((((class grayscale color) | |
120 (background light)) | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
121 (:background "gray85")) |
17334 | 122 (((class grayscale color) |
123 (background dark)) | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
124 (:background "dim gray")) |
17334 | 125 (t |
126 (:italic t))) | |
127 "Face used for editable fields." | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
128 :group 'widget-faces) |
17334 | 129 |
18562
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
130 (defface widget-single-line-field-face '((((class grayscale color) |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
131 (background light)) |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
132 (:background "gray85")) |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
133 (((class grayscale color) |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
134 (background dark)) |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
135 (:background "dim gray")) |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
136 (t |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
137 (:italic t))) |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
138 "Face used for editable fields spanning only a single line." |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
139 :group 'widget-faces) |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
140 |
19256
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
141 ;;; This causes display-table to be loaded, and not usefully. |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
142 ;;;(defvar widget-single-line-display-table |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
143 ;;; (let ((table (make-display-table))) |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
144 ;;; (aset table 9 "^I") |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
145 ;;; (aset table 10 "^J") |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
146 ;;; table) |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
147 ;;; "Display table used for single-line editable fields.") |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
148 |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
149 ;;;(when (fboundp 'set-face-display-table) |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
150 ;;; (set-face-display-table 'widget-single-line-field-face |
e4b14e6fd28f
(widget-single-line-display-table): Variable
Richard M. Stallman <rms@gnu.org>
parents:
19022
diff
changeset
|
151 ;;; widget-single-line-display-table)) |
18562
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
152 |
17334 | 153 ;;; Utility functions. |
154 ;; | |
155 ;; These are not really widget specific. | |
156 | |
157 (defun widget-princ-to-string (object) | |
158 ;; Return string representation of OBJECT, any Lisp object. | |
159 ;; No quoting characters are used; no delimiters are printed around | |
160 ;; the contents of strings. | |
161 (save-excursion | |
162 (set-buffer (get-buffer-create " *widget-tmp*")) | |
163 (erase-buffer) | |
164 (let ((standard-output (current-buffer))) | |
165 (princ object)) | |
166 (buffer-string))) | |
167 | |
168 (defun widget-clear-undo () | |
169 "Clear all undo information." | |
170 (buffer-disable-undo (current-buffer)) | |
171 (buffer-enable-undo)) | |
172 | |
17799 | 173 (defcustom widget-menu-max-size 40 |
174 "Largest number of items allowed in a popup-menu. | |
175 Larger menus are read through the minibuffer." | |
176 :group 'widgets | |
177 :type 'integer) | |
178 | |
23243
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
179 (defcustom widget-menu-max-shortcuts 40 |
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
180 "Largest number of items for which it works to choose one with a character. |
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
181 For a larger number of items, the minibuffer is used." |
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
182 :group 'widgets |
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
183 :type 'integer) |
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
184 |
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
185 (defcustom widget-menu-minibuffer-flag nil |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
186 "*Control how to ask for a choice from the keyboard. |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
187 Non-nil means use the minibuffer; |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
188 nil means read a single character." |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
189 :group 'widgets |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
190 :type 'boolean) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
191 |
17334 | 192 (defun widget-choose (title items &optional event) |
193 "Choose an item from a list. | |
194 | |
195 First argument TITLE is the name of the list. | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
196 Second argument ITEMS is an list whose members are either |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
197 (NAME . VALUE), to indicate selectable items, or just strings to |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
198 indicate unselectable items. |
17334 | 199 Optional third argument EVENT is an input event. |
200 | |
201 The user is asked to choose between each NAME from the items alist, | |
202 and the VALUE of the chosen element will be returned. If EVENT is a | |
203 mouse event, and the number of elements in items is less than | |
204 `widget-menu-max-size', a popup menu will be used, otherwise the | |
205 minibuffer." | |
206 (cond ((and (< (length items) widget-menu-max-size) | |
207 event (fboundp 'x-popup-menu) window-system) | |
208 ;; We are in Emacs-19, pressed by the mouse | |
209 (x-popup-menu event | |
210 (list title (cons "" items)))) | |
23243
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
211 ((or widget-menu-minibuffer-flag |
b6c86c56e760
(widget-menu-max-shortcuts): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
22941
diff
changeset
|
212 (> (length items) widget-menu-max-shortcuts)) |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
213 ;; Read the choice of name from the minibuffer. |
18056
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
214 (setq items (widget-remove-if 'stringp items)) |
17334 | 215 (let ((val (completing-read (concat title ": ") items nil t))) |
216 (if (stringp val) | |
217 (let ((try (try-completion val items))) | |
218 (when (stringp try) | |
219 (setq val try)) | |
220 (cdr (assoc val items))) | |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
221 nil))) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
222 (t |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
223 ;; Construct a menu of the choices |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
224 ;; and then use it for prompting for a single character. |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
225 (let* ((overriding-terminal-local-map |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
226 (make-sparse-keymap)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
227 map choice (next-digit ?0) |
18638
ac27714a02cf
(widget-field-use-before-change): Reenable for Emacs 20.
Richard M. Stallman <rms@gnu.org>
parents:
18600
diff
changeset
|
228 some-choice-enabled |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
229 value) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
230 ;; Define SPC as a prefix char to get to this menu. |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
231 (define-key overriding-terminal-local-map " " |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
232 (setq map (make-sparse-keymap title))) |
18461
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
233 (save-excursion |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
234 (set-buffer (get-buffer-create " widget-choose")) |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
235 (erase-buffer) |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
236 (insert "Available choices:\n\n") |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
237 (while items |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
238 (setq choice (car items) items (cdr items)) |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
239 (if (consp choice) |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
240 (let* ((name (car choice)) |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
241 (function (cdr choice))) |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
242 (insert (format "%c = %s\n" next-digit name)) |
18638
ac27714a02cf
(widget-field-use-before-change): Reenable for Emacs 20.
Richard M. Stallman <rms@gnu.org>
parents:
18600
diff
changeset
|
243 (define-key map (vector next-digit) function) |
ac27714a02cf
(widget-field-use-before-change): Reenable for Emacs 20.
Richard M. Stallman <rms@gnu.org>
parents:
18600
diff
changeset
|
244 (setq some-choice-enabled t))) |
18461
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
245 ;; Allocate digits to disabled alternatives |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
246 ;; so that the digit of a given alternative never varies. |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
247 (setq next-digit (1+ next-digit))) |
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
248 (insert "\nC-g = Quit")) |
18638
ac27714a02cf
(widget-field-use-before-change): Reenable for Emacs 20.
Richard M. Stallman <rms@gnu.org>
parents:
18600
diff
changeset
|
249 (or some-choice-enabled |
ac27714a02cf
(widget-field-use-before-change): Reenable for Emacs 20.
Richard M. Stallman <rms@gnu.org>
parents:
18600
diff
changeset
|
250 (error "None of the choices is currently meaningful")) |
18461
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
251 (define-key map [?\C-g] 'keyboard-quit) |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
252 (define-key map [t] 'keyboard-quit) |
20466
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
253 (define-key map [?\M-\C-v] 'scroll-other-window) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
254 (define-key map [?\M--] 'negative-argument) |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
255 (setcdr map (nreverse (cdr map))) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
256 ;; Read a char with the menu, and return the result |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
257 ;; that corresponds to it. |
18461
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
258 (save-window-excursion |
20466
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
259 (let ((buf (get-buffer " widget-choose"))) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
260 (display-buffer buf) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
261 (let ((cursor-in-echo-area t) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
262 keys |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
263 (char 0) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
264 (arg 1)) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
265 (while (not (or (and (>= char ?0) (< char next-digit)) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
266 (eq value 'keyboard-quit))) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
267 ;; Unread a SPC to lead to our new menu. |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
268 (setq unread-command-events (cons ?\ unread-command-events)) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
269 (setq keys (read-key-sequence title)) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
270 (setq value (lookup-key overriding-terminal-local-map keys t) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
271 char (string-to-char (substring keys 1))) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
272 (cond ((eq value 'scroll-other-window) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
273 (let ((minibuffer-scroll-window (get-buffer-window buf))) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
274 (if (> 0 arg) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
275 (scroll-other-window-down (window-height minibuffer-scroll-window)) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
276 (scroll-other-window)) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
277 (setq arg 1))) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
278 ((eq value 'negative-argument) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
279 (setq arg -1)) |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
280 (t |
38cee46393d4
(widget-choose): Allow scrolling of large lists.
Karl Heuer <kwzh@gnu.org>
parents:
20073
diff
changeset
|
281 (setq arg 1))))))) |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
282 (when (eq value 'keyboard-quit) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
283 (error "Canceled")) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
284 value)))) |
17334 | 285 |
18056
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
286 (defun widget-remove-if (predictate list) |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
287 (let (result (tail list)) |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
288 (while tail |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
289 (or (funcall predictate (car tail)) |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
290 (setq result (cons (car tail) result))) |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
291 (setq tail (cdr tail))) |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
292 (nreverse result))) |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
293 |
17334 | 294 ;;; Widget text specifications. |
295 ;; | |
296 ;; These functions are for specifying text properties. | |
297 | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
298 (defcustom widget-field-add-space |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
299 (or (< emacs-major-version 20) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
300 (and (eq emacs-major-version 20) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
301 (< emacs-minor-version 3)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
302 (not (string-match "XEmacs" emacs-version))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
303 "Non-nil means add extra space at the end of editable text fields. |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
304 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
305 This is needed on all versions of Emacs, and on XEmacs before 20.3. |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
306 If you don't add the space, it will become impossible to edit a zero |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
307 size field." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
308 :type 'boolean |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
309 :group 'widgets) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
310 |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
311 (defcustom widget-field-use-before-change |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
312 (and (or (> emacs-minor-version 34) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
313 (> emacs-major-version 19)) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
314 (not (string-match "XEmacs" emacs-version))) |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
315 "Non-nil means use `before-change-functions' to track editable fields. |
18638
ac27714a02cf
(widget-field-use-before-change): Reenable for Emacs 20.
Richard M. Stallman <rms@gnu.org>
parents:
18600
diff
changeset
|
316 This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
317 Using before hooks also means that the :notify function can't know the |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
318 new value." |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
319 :type 'boolean |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
320 :group 'widgets) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
321 |
17334 | 322 (defun widget-specify-field (widget from to) |
18090 | 323 "Specify editable button for WIDGET between FROM and TO." |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
324 ;; Terminating space is not part of the field, but necessary in |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
325 ;; order for local-map to work. Remove next sexp if local-map works |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
326 ;; at the end of the overlay. |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
327 (save-excursion |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
328 (goto-char to) |
18598
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
329 (cond ((null (widget-get widget :size)) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
330 (forward-char 1)) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
331 (widget-field-add-space |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
332 (insert-and-inherit " "))) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
333 (setq to (point))) |
17334 | 334 (let ((map (widget-get widget :keymap)) |
18090 | 335 (face (or (widget-get widget :value-face) 'widget-field-face)) |
336 (help-echo (widget-get widget :help-echo)) | |
18598
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
337 (overlay (make-overlay from to nil |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
338 nil (or (not widget-field-add-space) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
339 (widget-get widget :size))))) |
17334 | 340 (unless (or (stringp help-echo) (null help-echo)) |
18090 | 341 (setq help-echo 'widget-mouse-help)) |
342 (widget-put widget :field-overlay overlay) | |
343 (overlay-put overlay 'detachable nil) | |
344 (overlay-put overlay 'field widget) | |
345 (overlay-put overlay 'local-map map) | |
346 (overlay-put overlay 'keymap map) | |
347 (overlay-put overlay 'face face) | |
348 (overlay-put overlay 'balloon-help help-echo) | |
22422
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
349 (overlay-put overlay 'help-echo help-echo)) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
350 (widget-specify-secret widget)) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
351 |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
352 (defun widget-specify-secret (field) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
353 "Replace text in FIELD with value of `:secret', if non-nil." |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
354 (let ((secret (widget-get field :secret)) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
355 (size (widget-get field :size))) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
356 (when secret |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
357 (let ((begin (widget-field-start field)) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
358 (end (widget-field-end field))) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
359 (when size |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
360 (while (and (> end begin) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
361 (eq (char-after (1- end)) ?\ )) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
362 (setq end (1- end)))) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
363 (while (< begin end) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
364 (let ((old (char-after begin))) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
365 (unless (eq old secret) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
366 (subst-char-in-region begin (1+ begin) old secret) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
367 (put-text-property begin (1+ begin) 'secret old)) |
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
368 (setq begin (1+ begin)))))))) |
17334 | 369 |
370 (defun widget-specify-button (widget from to) | |
18090 | 371 "Specify button for WIDGET between FROM and TO." |
17334 | 372 (let ((face (widget-apply widget :button-face-get)) |
18090 | 373 (help-echo (widget-get widget :help-echo)) |
374 (overlay (make-overlay from to nil t nil))) | |
375 (widget-put widget :button-overlay overlay) | |
17334 | 376 (unless (or (null help-echo) (stringp help-echo)) |
377 (setq help-echo 'widget-mouse-help)) | |
18090 | 378 (overlay-put overlay 'button widget) |
379 (overlay-put overlay 'mouse-face widget-mouse-face) | |
380 (overlay-put overlay 'balloon-help help-echo) | |
381 (overlay-put overlay 'help-echo help-echo) | |
382 (overlay-put overlay 'face face))) | |
17334 | 383 |
384 (defun widget-mouse-help (extent) | |
385 "Find mouse help string for button in extent." | |
386 (let* ((widget (widget-at (extent-start-position extent))) | |
387 (help-echo (and widget (widget-get widget :help-echo)))) | |
388 (cond ((stringp help-echo) | |
389 help-echo) | |
390 ((and (symbolp help-echo) (fboundp help-echo) | |
391 (stringp (setq help-echo (funcall help-echo widget)))) | |
392 help-echo) | |
393 (t | |
394 (format "(widget %S :help-echo %S)" widget help-echo))))) | |
395 | |
396 (defun widget-specify-sample (widget from to) | |
397 ;; Specify sample for WIDGET between FROM and TO. | |
18600
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
398 (let ((face (widget-apply widget :sample-face-get)) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
399 (overlay (make-overlay from to nil t nil))) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
400 (overlay-put overlay 'face face) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
401 (widget-put widget :sample-overlay overlay))) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
402 |
17334 | 403 (defun widget-specify-doc (widget from to) |
404 ;; Specify documentation for WIDGET between FROM and TO. | |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
405 (let ((overlay (make-overlay from to nil t nil))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
406 (overlay-put overlay 'widget-doc widget) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
407 (overlay-put overlay 'face widget-documentation-face) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
408 (widget-put widget :doc-overlay overlay))) |
17334 | 409 |
410 (defmacro widget-specify-insert (&rest form) | |
411 ;; Execute FORM without inheriting any text properties. | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
412 (` |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
413 (save-restriction |
17334 | 414 (let ((inhibit-read-only t) |
415 result | |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
416 before-change-functions |
17334 | 417 after-change-functions) |
418 (insert "<>") | |
419 (narrow-to-region (- (point) 2) (point)) | |
420 (goto-char (1+ (point-min))) | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
421 (setq result (progn (,@ form))) |
17334 | 422 (delete-region (point-min) (1+ (point-min))) |
423 (delete-region (1- (point-max)) (point-max)) | |
424 (goto-char (point-max)) | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
425 result)))) |
17334 | 426 |
427 (defface widget-inactive-face '((((class grayscale color) | |
428 (background dark)) | |
429 (:foreground "light gray")) | |
430 (((class grayscale color) | |
431 (background light)) | |
18337 | 432 (:foreground "dim gray")) |
17334 | 433 (t |
434 (:italic t))) | |
435 "Face used for inactive widgets." | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
436 :group 'widget-faces) |
17334 | 437 |
438 (defun widget-specify-inactive (widget from to) | |
439 "Make WIDGET inactive for user modifications." | |
440 (unless (widget-get widget :inactive) | |
441 (let ((overlay (make-overlay from to nil t nil))) | |
442 (overlay-put overlay 'face 'widget-inactive-face) | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
443 ;; This is disabled, as it makes the mouse cursor change shape. |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
444 ;; (overlay-put overlay 'mouse-face 'widget-inactive-face) |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
445 (overlay-put overlay 'evaporate t) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
446 (overlay-put overlay 'priority 100) |
17334 | 447 (overlay-put overlay (if (string-match "XEmacs" emacs-version) |
448 'read-only | |
449 'modification-hooks) '(widget-overlay-inactive)) | |
450 (widget-put widget :inactive overlay)))) | |
451 | |
452 (defun widget-overlay-inactive (&rest junk) | |
453 "Ignoring the arguments, signal an error." | |
454 (unless inhibit-read-only | |
455 (error "Attempt to modify inactive widget"))) | |
456 | |
457 | |
458 (defun widget-specify-active (widget) | |
459 "Make WIDGET active for user modifications." | |
460 (let ((inactive (widget-get widget :inactive))) | |
461 (when inactive | |
462 (delete-overlay inactive) | |
463 (widget-put widget :inactive nil)))) | |
464 | |
465 ;;; Widget Properties. | |
466 | |
467 (defsubst widget-type (widget) | |
468 "Return the type of WIDGET, a symbol." | |
469 (car widget)) | |
470 | |
18364
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
471 (defun widget-get-indirect (widget property) |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
472 "In WIDGET, get the value of PROPERTY. |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
473 If the value is a symbol, return its binding. |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
474 Otherwise, just return the value." |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
475 (let ((value (widget-get widget property))) |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
476 (if (symbolp value) |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
477 (symbol-value value) |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
478 value))) |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
479 |
17334 | 480 (defun widget-member (widget property) |
481 "Non-nil iff there is a definition in WIDGET for PROPERTY." | |
482 (cond ((widget-plist-member (cdr widget) property) | |
483 t) | |
484 ((car widget) | |
485 (widget-member (get (car widget) 'widget-type) property)) | |
486 (t nil))) | |
487 | |
488 (defun widget-value (widget) | |
489 "Extract the current value of WIDGET." | |
490 (widget-apply widget | |
491 :value-to-external (widget-apply widget :value-get))) | |
492 | |
493 (defun widget-value-set (widget value) | |
494 "Set the current value of WIDGET to VALUE." | |
495 (widget-apply widget | |
496 :value-set (widget-apply widget | |
497 :value-to-internal value))) | |
498 | |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
499 (defun widget-default-get (widget) |
22496
cad4818f198f
(widget-default-get): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
22468
diff
changeset
|
500 "Extract the default value of WIDGET." |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
501 (or (widget-get widget :value) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
502 (widget-apply widget :default-get))) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
503 |
17334 | 504 (defun widget-match-inline (widget vals) |
505 ;; In WIDGET, match the start of VALS. | |
506 (cond ((widget-get widget :inline) | |
507 (widget-apply widget :match-inline vals)) | |
508 ((and vals | |
509 (widget-apply widget :match (car vals))) | |
510 (cons (list (car vals)) (cdr vals))) | |
511 (t nil))) | |
512 | |
513 (defun widget-apply-action (widget &optional event) | |
514 "Apply :action in WIDGET in response to EVENT." | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
515 (if (widget-apply widget :active) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
516 (widget-apply widget :action event) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
517 (error "Attempt to perform action on inactive widget"))) |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
518 |
17799 | 519 ;;; Helper functions. |
520 ;; | |
521 ;; These are widget specific. | |
522 | |
523 ;;;###autoload | |
524 (defun widget-prompt-value (widget prompt &optional value unbound) | |
525 "Prompt for a value matching WIDGET, using PROMPT. | |
526 The current value is assumed to be VALUE, unless UNBOUND is non-nil." | |
527 (unless (listp widget) | |
528 (setq widget (list widget))) | |
529 (setq prompt (format "[%s] %s" (widget-type widget) prompt)) | |
530 (setq widget (widget-convert widget)) | |
531 (let ((answer (widget-apply widget :prompt-value prompt value unbound))) | |
532 (unless (widget-apply widget :match answer) | |
533 (error "Value does not match %S type." (car widget))) | |
534 answer)) | |
535 | |
536 (defun widget-get-sibling (widget) | |
537 "Get the item WIDGET is assumed to toggle. | |
538 This is only meaningful for radio buttons or checkboxes in a list." | |
539 (let* ((parent (widget-get widget :parent)) | |
540 (children (widget-get parent :children)) | |
541 child) | |
542 (catch 'child | |
543 (while children | |
544 (setq child (car children) | |
545 children (cdr children)) | |
546 (when (eq (widget-get child :button) widget) | |
547 (throw 'child child))) | |
548 nil))) | |
549 | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
550 (defun widget-map-buttons (function &optional buffer maparg) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
551 "Map FUNCTION over the buttons in BUFFER. |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
552 FUNCTION is called with the arguments WIDGET and MAPARG. |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
553 |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
554 If FUNCTION returns non-nil, the walk is cancelled. |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
555 |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
556 The arguments MAPARG, and BUFFER default to nil and (current-buffer), |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
557 respectively." |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
558 (let ((cur (point-min)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
559 (widget nil) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
560 (parent nil) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
561 (overlays (if buffer |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
562 (save-excursion (set-buffer buffer) (overlay-lists)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
563 (overlay-lists)))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
564 (setq overlays (append (car overlays) (cdr overlays))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
565 (while (setq cur (pop overlays)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
566 (setq widget (overlay-get cur 'button)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
567 (if (and widget (funcall function widget maparg)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
568 (setq overlays nil))))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
569 |
17334 | 570 ;;; Glyphs. |
571 | |
572 (defcustom widget-glyph-directory (concat data-directory "custom/") | |
573 "Where widget glyphs are located. | |
574 If this variable is nil, widget will try to locate the directory | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
575 automatically." |
17334 | 576 :group 'widgets |
577 :type 'directory) | |
578 | |
579 (defcustom widget-glyph-enable t | |
580 "If non nil, use glyphs in images when available." | |
581 :group 'widgets | |
582 :type 'boolean) | |
583 | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
584 (defcustom widget-image-conversion |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
585 '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg") |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
586 (xbm ".xbm")) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
587 "Conversion alist from image formats to file name suffixes." |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
588 :group 'widgets |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
589 :type '(repeat (cons :format "%v" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
590 (symbol :tag "Image Format" unknown) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
591 (repeat :tag "Suffixes" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
592 (string :format "%v"))))) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
593 |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
594 (defun widget-glyph-find (image tag) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
595 "Create a glyph corresponding to IMAGE with string TAG as fallback. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
596 IMAGE should either already be a glyph, or be a file name sans |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
597 extension (xpm, xbm, gif, jpg, or png) located in |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
598 `widget-glyph-directory'." |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
599 (cond ((not (and image |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
600 (string-match "XEmacs" emacs-version) |
17334 | 601 widget-glyph-enable |
602 (fboundp 'make-glyph) | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
603 (fboundp 'locate-file) |
17334 | 604 image)) |
605 ;; We don't want or can't use glyphs. | |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
606 nil) |
17334 | 607 ((and (fboundp 'glyphp) |
608 (glyphp image)) | |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
609 ;; Already a glyph. Use it. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
610 image) |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
611 ((stringp image) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
612 ;; A string. Look it up in relevant directories. |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
613 (let* ((dirlist (list (or widget-glyph-directory |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
614 (concat data-directory |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
615 "custom/")) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
616 data-directory)) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
617 (formats widget-image-conversion) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
618 file) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
619 (while (and formats (not file)) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
620 (when (valid-image-instantiator-format-p (car (car formats))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
621 (setq file (locate-file image dirlist |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
622 (mapconcat 'identity |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
623 (cdr (car formats)) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
624 ":")))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
625 (unless file |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
626 (setq formats (cdr formats)))) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
627 (and file |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
628 ;; We create a glyph with the file as the default image |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
629 ;; instantiator, and the TAG fallback |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
630 (make-glyph (list (vector (car (car formats)) ':file file) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
631 (vector 'string ':data tag)))))) |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
632 ((valid-instantiator-p image 'image) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
633 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
634 (make-glyph (list image |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
635 (vector 'string ':data tag)))) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
636 ((consp image) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
637 ;; This could be virtually anything. Let `make-glyph' sort it out. |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
638 (make-glyph image)) |
17334 | 639 (t |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
640 ;; Oh well. |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
641 nil))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
642 |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
643 (defun widget-glyph-insert (widget tag image &optional down inactive) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
644 "In WIDGET, insert the text TAG or, if supported, IMAGE. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
645 IMAGE should either be a glyph, an image instantiator, or an image file |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
646 name sans extension (xpm, xbm, gif, jpg, or png) located in |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
647 `widget-glyph-directory'. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
648 |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
649 Optional arguments DOWN and INACTIVE is used instead of IMAGE when the |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
650 glyph is pressed or inactive, respectively. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
651 |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
652 WARNING: If you call this with a glyph, and you want the user to be |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
653 able to invoke the glyph, make sure it is unique. If you use the |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
654 same glyph for multiple widgets, invoking any of the glyphs will |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
655 cause the last created widget to be invoked. |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
656 |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
657 Instead of an instantiator, you can also use a list of instantiators, |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
658 or whatever `make-glyph' will accept. However, in that case you must |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
659 provide the fallback TAG as a part of the instantiator yourself." |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
660 (let ((glyph (widget-glyph-find image tag))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
661 (if glyph |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
662 (widget-glyph-insert-glyph widget |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
663 glyph |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
664 (widget-glyph-find down tag) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
665 (widget-glyph-find inactive tag)) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
666 (insert tag)))) |
17334 | 667 |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
668 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
669 "In WIDGET, insert GLYPH. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
670 If optional arguments DOWN and INACTIVE are given, they should be |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
671 glyphs used when the widget is pushed and inactive, respectively." |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
672 (when widget |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
673 (set-glyph-property glyph 'widget widget) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
674 (when down |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
675 (set-glyph-property down 'widget widget)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
676 (when inactive |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
677 (set-glyph-property inactive 'widget widget))) |
17334 | 678 (insert "*") |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
679 (let ((ext (make-extent (point) (1- (point)))) |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
680 (help-echo (and widget (widget-get widget :help-echo)))) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
681 (set-extent-property ext 'invisible t) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
682 (set-extent-property ext 'start-open t) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
683 (set-extent-property ext 'end-open t) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
684 (set-extent-end-glyph ext glyph) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
685 (when help-echo |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
686 (set-extent-property ext 'balloon-help help-echo) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
687 (set-extent-property ext 'help-echo help-echo))) |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
688 (when widget |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
689 (widget-put widget :glyph-up glyph) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
690 (when down (widget-put widget :glyph-down down)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
691 (when inactive (widget-put widget :glyph-inactive inactive)))) |
17334 | 692 |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
693 ;;; Buttons. |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
694 |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
695 (defgroup widget-button nil |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
696 "The look of various kinds of buttons." |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
697 :group 'widgets) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
698 |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
699 (defcustom widget-button-prefix "" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
700 "String used as prefix for buttons." |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
701 :type 'string |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
702 :group 'widget-button) |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
703 |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
704 (defcustom widget-button-suffix "" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
705 "String used as suffix for buttons." |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
706 :type 'string |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
707 :group 'widget-button) |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
708 |
17334 | 709 ;;; Creating Widgets. |
710 | |
711 ;;;###autoload | |
712 (defun widget-create (type &rest args) | |
713 "Create widget of TYPE. | |
714 The optional ARGS are additional keyword arguments." | |
715 (let ((widget (apply 'widget-convert type args))) | |
716 (widget-apply widget :create) | |
717 widget)) | |
718 | |
719 (defun widget-create-child-and-convert (parent type &rest args) | |
720 "As part of the widget PARENT, create a child widget TYPE. | |
721 The child is converted, using the keyword arguments ARGS." | |
722 (let ((widget (apply 'widget-convert type args))) | |
723 (widget-put widget :parent parent) | |
724 (unless (widget-get widget :indent) | |
725 (widget-put widget :indent (+ (or (widget-get parent :indent) 0) | |
726 (or (widget-get widget :extra-offset) 0) | |
727 (widget-get parent :offset)))) | |
728 (widget-apply widget :create) | |
729 widget)) | |
730 | |
731 (defun widget-create-child (parent type) | |
732 "Create widget of TYPE." | |
17535
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
733 (let ((widget (copy-sequence type))) |
17334 | 734 (widget-put widget :parent parent) |
735 (unless (widget-get widget :indent) | |
736 (widget-put widget :indent (+ (or (widget-get parent :indent) 0) | |
737 (or (widget-get widget :extra-offset) 0) | |
738 (widget-get parent :offset)))) | |
739 (widget-apply widget :create) | |
740 widget)) | |
741 | |
742 (defun widget-create-child-value (parent type value) | |
743 "Create widget of TYPE with value VALUE." | |
17535
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
744 (let ((widget (copy-sequence type))) |
17334 | 745 (widget-put widget :value (widget-apply widget :value-to-internal value)) |
746 (widget-put widget :parent parent) | |
747 (unless (widget-get widget :indent) | |
748 (widget-put widget :indent (+ (or (widget-get parent :indent) 0) | |
749 (or (widget-get widget :extra-offset) 0) | |
750 (widget-get parent :offset)))) | |
751 (widget-apply widget :create) | |
752 widget)) | |
753 | |
754 ;;;###autoload | |
755 (defun widget-delete (widget) | |
756 "Delete WIDGET." | |
757 (widget-apply widget :delete)) | |
758 | |
759 (defun widget-convert (type &rest args) | |
760 "Convert TYPE to a widget without inserting it in the buffer. | |
761 The optional ARGS are additional keyword arguments." | |
762 ;; Don't touch the type. | |
763 (let* ((widget (if (symbolp type) | |
764 (list type) | |
17535
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
765 (copy-sequence type))) |
17334 | 766 (current widget) |
767 (keys args)) | |
768 ;; First set the :args keyword. | |
769 (while (cdr current) ;Look in the type. | |
770 (let ((next (car (cdr current)))) | |
771 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
772 (setq current (cdr (cdr current))) | |
773 (setcdr current (list :args (cdr current))) | |
774 (setq current nil)))) | |
775 (while args ;Look in the args. | |
776 (let ((next (nth 0 args))) | |
777 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
778 (setq args (nthcdr 2 args)) | |
779 (widget-put widget :args args) | |
780 (setq args nil)))) | |
781 ;; Then Convert the widget. | |
782 (setq type widget) | |
783 (while type | |
784 (let ((convert-widget (plist-get (cdr type) :convert-widget))) | |
785 (if convert-widget | |
786 (setq widget (funcall convert-widget widget)))) | |
787 (setq type (get (car type) 'widget-type))) | |
788 ;; Finally set the keyword args. | |
789 (while keys | |
790 (let ((next (nth 0 keys))) | |
791 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
792 (progn | |
793 (widget-put widget next (nth 1 keys)) | |
794 (setq keys (nthcdr 2 keys))) | |
795 (setq keys nil)))) | |
796 ;; Convert the :value to internal format. | |
797 (if (widget-member widget :value) | |
798 (let ((value (widget-get widget :value))) | |
799 (widget-put widget | |
800 :value (widget-apply widget :value-to-internal value)))) | |
801 ;; Return the newly create widget. | |
802 widget)) | |
803 | |
804 (defun widget-insert (&rest args) | |
805 "Call `insert' with ARGS and make the text read only." | |
806 (let ((inhibit-read-only t) | |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
807 before-change-functions |
17334 | 808 after-change-functions |
809 (from (point))) | |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
810 (apply 'insert args))) |
17334 | 811 |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
812 (defun widget-convert-text (type from to |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
813 &optional button-from button-to |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
814 &rest args) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
815 "Return a widget of type TYPE with endpoint FROM TO. |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
816 Optional ARGS are extra keyword arguments for TYPE. |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
817 and TO will be used as the widgets end points. If optional arguments |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
818 BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
819 button end points. |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
820 Optional ARGS are extra keyword arguments for TYPE." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
821 (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
822 (from (copy-marker from)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
823 (to (copy-marker to))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
824 (set-marker-insertion-type from t) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
825 (set-marker-insertion-type to nil) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
826 (widget-put widget :from from) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
827 (widget-put widget :to to) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
828 (when button-from |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
829 (widget-specify-button widget button-from button-to)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
830 widget)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
831 |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
832 (defun widget-convert-button (type from to &rest args) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
833 "Return a widget of type TYPE with endpoint FROM TO. |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
834 Optional ARGS are extra keyword arguments for TYPE. |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
835 No text will be inserted to the buffer, instead the text between FROM |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
836 and TO will be used as the widgets end points, as well as the widgets |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
837 button end points." |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
838 (apply 'widget-convert-text type from to from to args)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
839 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
840 (defun widget-leave-text (widget) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
841 "Remove markers and overlays from WIDGET and its children." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
842 (let ((from (widget-get widget :from)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
843 (to (widget-get widget :to)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
844 (button (widget-get widget :button-overlay)) |
18600
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
845 (sample (widget-get widget :sample-overlay)) |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
846 (doc (widget-get widget :doc-overlay)) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
847 (field (widget-get widget :field-overlay)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
848 (children (widget-get widget :children))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
849 (set-marker from nil) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
850 (set-marker to nil) |
18338
e15d8860f504
Don't delete nil overlays.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18337
diff
changeset
|
851 (when button |
e15d8860f504
Don't delete nil overlays.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18337
diff
changeset
|
852 (delete-overlay button)) |
18600
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
853 (when sample |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
854 (delete-overlay sample)) |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
855 (when doc |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
856 (delete-overlay doc)) |
18338
e15d8860f504
Don't delete nil overlays.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18337
diff
changeset
|
857 (when field |
e15d8860f504
Don't delete nil overlays.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18337
diff
changeset
|
858 (delete-overlay field)) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
859 (mapcar 'widget-leave-text children))) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
860 |
17334 | 861 ;;; Keymap and Commands. |
862 | |
863 (defvar widget-keymap nil | |
864 "Keymap containing useful binding for buffers containing widgets. | |
865 Recommended as a parent keymap for modes using widgets.") | |
866 | |
867 (unless widget-keymap | |
868 (setq widget-keymap (make-sparse-keymap)) | |
869 (define-key widget-keymap "\t" 'widget-forward) | |
870 (define-key widget-keymap [(shift tab)] 'widget-backward) | |
871 (define-key widget-keymap [backtab] 'widget-backward) | |
17799 | 872 (if (string-match "XEmacs" emacs-version) |
17334 | 873 (progn |
17799 | 874 ;;Glyph support. |
875 (define-key widget-keymap [button1] 'widget-button1-click) | |
876 (define-key widget-keymap [button2] 'widget-button-click)) | |
17334 | 877 (define-key widget-keymap [down-mouse-2] 'widget-button-click)) |
878 (define-key widget-keymap "\C-m" 'widget-button-press)) | |
879 | |
880 (defvar widget-global-map global-map | |
881 "Keymap used for events the widget does not handle themselves.") | |
882 (make-variable-buffer-local 'widget-global-map) | |
883 | |
884 (defvar widget-field-keymap nil | |
885 "Keymap used inside an editable field.") | |
886 | |
887 (unless widget-field-keymap | |
888 (setq widget-field-keymap (copy-keymap widget-keymap)) | |
889 (unless (string-match "XEmacs" (emacs-version)) | |
890 (define-key widget-field-keymap [menu-bar] 'nil)) | |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
891 (define-key widget-field-keymap "\C-k" 'widget-kill-line) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
892 (define-key widget-field-keymap "\M-\t" 'widget-complete) |
17334 | 893 (define-key widget-field-keymap "\C-m" 'widget-field-activate) |
894 (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line) | |
895 (define-key widget-field-keymap "\C-e" 'widget-end-of-line) | |
896 (set-keymap-parent widget-field-keymap global-map)) | |
897 | |
898 (defvar widget-text-keymap nil | |
899 "Keymap used inside a text field.") | |
900 | |
901 (unless widget-text-keymap | |
902 (setq widget-text-keymap (copy-keymap widget-keymap)) | |
903 (unless (string-match "XEmacs" (emacs-version)) | |
904 (define-key widget-text-keymap [menu-bar] 'nil)) | |
905 (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) | |
906 (define-key widget-text-keymap "\C-e" 'widget-end-of-line) | |
907 (set-keymap-parent widget-text-keymap global-map)) | |
908 | |
909 (defun widget-field-activate (pos &optional event) | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
910 "Invoke the ediable field at point." |
17334 | 911 (interactive "@d") |
18090 | 912 (let ((field (get-char-property pos 'field))) |
17334 | 913 (if field |
914 (widget-apply-action field event) | |
915 (call-interactively | |
916 (lookup-key widget-global-map (this-command-keys)))))) | |
917 | |
17799 | 918 (defface widget-button-pressed-face |
919 '((((class color)) | |
920 (:foreground "red")) | |
921 (t | |
922 (:bold t :underline t))) | |
923 "Face used for pressed buttons." | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
924 :group 'widget-faces) |
17799 | 925 |
17334 | 926 (defun widget-button-click (event) |
20064
697360ed5e4b
(widget-button-click): Move point to where clicked.
Karl Heuer <kwzh@gnu.org>
parents:
20006
diff
changeset
|
927 "Invoke the button that the mouse is pointing at, and move there." |
17334 | 928 (interactive "@e") |
20064
697360ed5e4b
(widget-button-click): Move point to where clicked.
Karl Heuer <kwzh@gnu.org>
parents:
20006
diff
changeset
|
929 (mouse-set-point event) |
17334 | 930 (cond ((and (fboundp 'event-glyph) |
931 (event-glyph event)) | |
17799 | 932 (widget-glyph-click event)) |
933 ((widget-event-point event) | |
934 (let* ((pos (widget-event-point event)) | |
18090 | 935 (button (get-char-property pos 'button))) |
17334 | 936 (if button |
18090 | 937 (let* ((overlay (widget-get button :button-overlay)) |
938 (face (overlay-get overlay 'face)) | |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
939 (mouse-face (overlay-get overlay 'mouse-face))) |
17799 | 940 (unwind-protect |
941 (let ((track-mouse t)) | |
18090 | 942 (overlay-put overlay |
943 'face 'widget-button-pressed-face) | |
17799 | 944 (overlay-put overlay |
945 'mouse-face 'widget-button-pressed-face) | |
946 (unless (widget-apply button :mouse-down-action event) | |
947 (while (not (button-release-event-p event)) | |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
948 (setq event (widget-read-event) |
17799 | 949 pos (widget-event-point event)) |
950 (if (and pos | |
18090 | 951 (eq (get-char-property pos 'button) |
17799 | 952 button)) |
953 (progn | |
954 (overlay-put overlay | |
955 'face | |
956 'widget-button-pressed-face) | |
957 (overlay-put overlay | |
958 'mouse-face | |
959 'widget-button-pressed-face)) | |
18090 | 960 (overlay-put overlay 'face face) |
961 (overlay-put overlay 'mouse-face mouse-face)))) | |
17799 | 962 (when (and pos |
18090 | 963 (eq (get-char-property pos 'button) button)) |
17799 | 964 (widget-apply-action button event))) |
18090 | 965 (overlay-put overlay 'face face) |
966 (overlay-put overlay 'mouse-face mouse-face))) | |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
967 (let ((up t) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
968 command) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
969 ;; Find the global command to run, and check whether it |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
970 ;; is bound to an up event. |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
971 (cond ((setq command ;down event |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
972 (lookup-key widget-global-map [ button2 ])) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
973 (setq up nil)) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
974 ((setq command ;down event |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
975 (lookup-key widget-global-map [ down-mouse-2 ])) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
976 (setq up nil)) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
977 ((setq command ;up event |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
978 (lookup-key widget-global-map [ button2up ]))) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
979 ((setq command ;up event |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
980 (lookup-key widget-global-map [ mouse-2])))) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
981 (when up |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
982 ;; Don't execute up events twice. |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
983 (while (not (button-release-event-p event)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
984 (setq event (widget-read-event)))) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
985 (when command |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
986 (call-interactively command)))))) |
17334 | 987 (t |
988 (message "You clicked somewhere weird.")))) | |
989 | |
990 (defun widget-button1-click (event) | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
991 "Invoke glyph below mouse pointer." |
17334 | 992 (interactive "@e") |
993 (if (and (fboundp 'event-glyph) | |
994 (event-glyph event)) | |
17799 | 995 (widget-glyph-click event) |
996 (call-interactively (lookup-key widget-global-map (this-command-keys))))) | |
997 | |
998 (defun widget-glyph-click (event) | |
999 "Handle click on a glyph." | |
1000 (let* ((glyph (event-glyph event)) | |
1001 (widget (glyph-property glyph 'widget)) | |
1002 (extent (event-glyph-extent event)) | |
1003 (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph)) | |
1004 (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph)) | |
1005 (last event)) | |
1006 ;; Wait for the release. | |
1007 (while (not (button-release-event-p last)) | |
1008 (if (eq extent (event-glyph-extent last)) | |
1009 (set-extent-property extent 'end-glyph down-glyph) | |
1010 (set-extent-property extent 'end-glyph up-glyph)) | |
21338
f94e2fdb6617
(widget-beginning-of-line): Don't set zmacs-region-stays.
Richard M. Stallman <rms@gnu.org>
parents:
21337
diff
changeset
|
1011 (setq last (read-event event))) |
17799 | 1012 ;; Release glyph. |
1013 (when down-glyph | |
1014 (set-extent-property extent 'end-glyph up-glyph)) | |
1015 ;; Apply widget action. | |
1016 (when (eq extent (event-glyph-extent last)) | |
17334 | 1017 (let ((widget (glyph-property (event-glyph event) 'widget))) |
17799 | 1018 (cond ((null widget) |
1019 (message "You clicked on a glyph.")) | |
1020 ((not (widget-apply widget :active)) | |
1021 (message "This glyph is inactive.")) | |
1022 (t | |
1023 (widget-apply-action widget event))))))) | |
17334 | 1024 |
1025 (defun widget-button-press (pos &optional event) | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1026 "Invoke button at POS." |
17334 | 1027 (interactive "@d") |
18090 | 1028 (let ((button (get-char-property pos 'button))) |
17334 | 1029 (if button |
1030 (widget-apply-action button event) | |
1031 (let ((command (lookup-key widget-global-map (this-command-keys)))) | |
1032 (when (commandp command) | |
1033 (call-interactively command)))))) | |
1034 | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1035 (defun widget-tabable-at (&optional pos) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1036 "Return the tabable widget at POS, or nil. |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1037 POS defaults to the value of (point)." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1038 (unless pos |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1039 (setq pos (point))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1040 (let ((widget (or (get-char-property (point) 'button) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1041 (get-char-property (point) 'field)))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1042 (if widget |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1043 (let ((order (widget-get widget :tab-order))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1044 (if order |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1045 (if (>= order 0) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1046 widget |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1047 nil) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1048 widget)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1049 nil))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1050 |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1051 (defcustom widget-use-overlay-change (string-match "XEmacs" emacs-version) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1052 "If non-nil, use overlay change functions to tab around in the buffer. |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1053 This is much faster, but doesn't work reliably on Emacs 19.34." |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1054 :type 'boolean |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1055 :group 'widgets) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1056 |
17334 | 1057 (defun widget-move (arg) |
1058 "Move point to the ARG next field or button. | |
1059 ARG may be negative to move backward." | |
18090 | 1060 (or (bobp) (> arg 0) (backward-char)) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1061 (let ((pos (point)) |
18090 | 1062 (number arg) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1063 (old (widget-tabable-at)) |
18090 | 1064 new) |
1065 ;; Forward. | |
1066 (while (> arg 0) | |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1067 (cond ((eobp) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1068 (goto-char (point-min))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1069 (widget-use-overlay-change |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1070 (goto-char (next-overlay-change (point)))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1071 (t |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1072 (forward-char 1))) |
18090 | 1073 (and (eq pos (point)) |
1074 (eq arg number) | |
1075 (error "No buttons or fields found")) | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1076 (let ((new (widget-tabable-at))) |
18090 | 1077 (when new |
1078 (unless (eq new old) | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1079 (setq arg (1- arg)) |
18090 | 1080 (setq old new))))) |
1081 ;; Backward. | |
1082 (while (< arg 0) | |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1083 (cond ((bobp) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1084 (goto-char (point-max))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1085 (widget-use-overlay-change |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1086 (goto-char (previous-overlay-change (point)))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1087 (t |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1088 (backward-char 1))) |
18090 | 1089 (and (eq pos (point)) |
1090 (eq arg number) | |
1091 (error "No buttons or fields found")) | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1092 (let ((new (widget-tabable-at))) |
18090 | 1093 (when new |
1094 (unless (eq new old) | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1095 (setq arg (1+ arg)))))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1096 (let ((new (widget-tabable-at))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1097 (while (eq (widget-tabable-at) new) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1098 (backward-char))) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1099 (forward-char)) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1100 (widget-echo-help (point)) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1101 (run-hooks 'widget-move-hook)) |
17334 | 1102 |
1103 (defun widget-forward (arg) | |
1104 "Move point to the next field or button. | |
1105 With optional ARG, move across that many fields." | |
1106 (interactive "p") | |
1107 (run-hooks 'widget-forward-hook) | |
1108 (widget-move arg)) | |
1109 | |
1110 (defun widget-backward (arg) | |
1111 "Move point to the previous field or button. | |
1112 With optional ARG, move across that many fields." | |
1113 (interactive "p") | |
1114 (run-hooks 'widget-backward-hook) | |
1115 (widget-move (- arg))) | |
1116 | |
1117 (defun widget-beginning-of-line () | |
1118 "Go to beginning of field or beginning of line, whichever is first." | |
1119 (interactive) | |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1120 (let* ((field (widget-field-find (point))) |
22941
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1121 (start (and field (widget-field-start field))) |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1122 (bol (save-excursion |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1123 (beginning-of-line) |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1124 (point)))) |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1125 (goto-char (if start |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1126 (max start bol) |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1127 bol)))) |
17334 | 1128 |
1129 (defun widget-end-of-line () | |
1130 "Go to end of field or end of line, whichever is first." | |
1131 (interactive) | |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1132 (let* ((field (widget-field-find (point))) |
22941
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1133 (end (and field (widget-field-end field))) |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1134 (eol (save-excursion |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1135 (end-of-line) |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1136 (point)))) |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1137 (goto-char (if end |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1138 (min end eol) |
b00170a05570
(widget-beginning-of-line): Properly handle
Richard M. Stallman <rms@gnu.org>
parents:
22496
diff
changeset
|
1139 eol)))) |
17334 | 1140 |
1141 (defun widget-kill-line () | |
1142 "Kill to end of field or end of line, whichever is first." | |
1143 (interactive) | |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1144 (let* ((field (widget-field-find (point))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1145 (newline (save-excursion (forward-line 1) (point))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1146 (end (and field (widget-field-end field)))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1147 (if (and field (> newline end)) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1148 (kill-region (point) end) |
17334 | 1149 (call-interactively 'kill-line)))) |
1150 | |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1151 (defcustom widget-complete-field (lookup-key global-map "\M-\t") |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1152 "Default function to call for completion inside fields." |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1153 :options '(ispell-complete-word complete-tag lisp-complete-symbol) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1154 :type 'function |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1155 :group 'widgets) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1156 |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1157 (defun widget-complete () |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1158 "Complete content of editable field from point. |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1159 When not inside a field, move to the previous button or field." |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1160 (interactive) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1161 (let ((field (widget-field-find (point)))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1162 (if field |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1163 (widget-apply field :complete) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1164 (error "Not in an editable field")))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1165 |
17334 | 1166 ;;; Setting up the buffer. |
1167 | |
1168 (defvar widget-field-new nil) | |
1169 ;; List of all newly created editable fields in the buffer. | |
1170 (make-variable-buffer-local 'widget-field-new) | |
1171 | |
1172 (defvar widget-field-list nil) | |
1173 ;; List of all editable fields in the buffer. | |
1174 (make-variable-buffer-local 'widget-field-list) | |
1175 | |
1176 (defun widget-setup () | |
1177 "Setup current buffer so editing string widgets works." | |
1178 (let ((inhibit-read-only t) | |
1179 (after-change-functions nil) | |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
1180 before-change-functions |
17334 | 1181 field) |
1182 (while widget-field-new | |
1183 (setq field (car widget-field-new) | |
1184 widget-field-new (cdr widget-field-new) | |
1185 widget-field-list (cons field widget-field-list)) | |
18090 | 1186 (let ((from (car (widget-get field :field-overlay))) |
1187 (to (cdr (widget-get field :field-overlay)))) | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1188 (widget-specify-field field |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1189 (marker-position from) (marker-position to)) |
18090 | 1190 (set-marker from nil) |
1191 (set-marker to nil)))) | |
17334 | 1192 (widget-clear-undo) |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1193 (widget-add-change)) |
17334 | 1194 |
1195 (defvar widget-field-last nil) | |
1196 ;; Last field containing point. | |
1197 (make-variable-buffer-local 'widget-field-last) | |
1198 | |
1199 (defvar widget-field-was nil) | |
1200 ;; The widget data before the change. | |
1201 (make-variable-buffer-local 'widget-field-was) | |
1202 | |
18090 | 1203 (defun widget-field-buffer (widget) |
1204 "Return the start of WIDGET's editing field." | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1205 (let ((overlay (widget-get widget :field-overlay))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1206 (and overlay (overlay-buffer overlay)))) |
18090 | 1207 |
1208 (defun widget-field-start (widget) | |
1209 "Return the start of WIDGET's editing field." | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1210 (let ((overlay (widget-get widget :field-overlay))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1211 (and overlay (overlay-start overlay)))) |
18090 | 1212 |
1213 (defun widget-field-end (widget) | |
1214 "Return the end of WIDGET's editing field." | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1215 (let ((overlay (widget-get widget :field-overlay))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1216 ;; Don't subtract one if local-map works at the end of the overlay. |
18598
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1217 (and overlay (if (or widget-field-add-space |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1218 (null (widget-get widget :size))) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1219 (1- (overlay-end overlay)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1220 (overlay-end overlay))))) |
18090 | 1221 |
17334 | 1222 (defun widget-field-find (pos) |
18090 | 1223 "Return the field at POS. |
1224 Unlike (get-char-property POS 'field) this, works with empty fields too." | |
17334 | 1225 (let ((fields widget-field-list) |
1226 field found) | |
1227 (while fields | |
1228 (setq field (car fields) | |
1229 fields (cdr fields)) | |
18090 | 1230 (let ((start (widget-field-start field)) |
1231 (end (widget-field-end field))) | |
1232 (when (and (<= start pos) (<= pos end)) | |
1233 (when found | |
1234 (debug "Overlapping fields")) | |
1235 (setq found field)))) | |
17334 | 1236 found)) |
1237 | |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1238 (defun widget-before-change (from to) |
18364
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
1239 ;; This is how, for example, a variable changes its state to `modified'. |
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
1240 ;; when it is being edited. |
19357
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1241 (unless inhibit-read-only |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1242 (let ((from-field (widget-field-find from)) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1243 (to-field (widget-field-find to))) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1244 (cond ((not (eq from-field to-field)) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1245 (add-hook 'post-command-hook 'widget-add-change nil t) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1246 (error "Change should be restricted to a single field")) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1247 ((null from-field) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1248 (add-hook 'post-command-hook 'widget-add-change nil t) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1249 (error "Attempt to change text outside editable field")) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1250 (widget-field-use-before-change |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1251 (condition-case nil |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1252 (widget-apply from-field :notify from-field) |
e2131e9d3bf6
(widget-before-change): Obey `inhibit-read-only'.
Richard M. Stallman <rms@gnu.org>
parents:
19256
diff
changeset
|
1253 (error (debug "Before Change")))))))) |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1254 |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1255 (defun widget-add-change () |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1256 (make-local-hook 'post-command-hook) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1257 (remove-hook 'post-command-hook 'widget-add-change t) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1258 (make-local-hook 'before-change-functions) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1259 (add-hook 'before-change-functions 'widget-before-change nil t) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1260 (make-local-hook 'after-change-functions) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1261 (add-hook 'after-change-functions 'widget-after-change nil t)) |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
1262 |
17334 | 1263 (defun widget-after-change (from to old) |
1264 ;; Adjust field size and text properties. | |
1265 (condition-case nil | |
1266 (let ((field (widget-field-find from)) | |
18090 | 1267 (other (widget-field-find to))) |
1268 (when field | |
1269 (unless (eq field other) | |
1270 (debug "Change in different fields")) | |
22422
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
1271 (let ((size (widget-get field :size))) |
18090 | 1272 (when size |
1273 (let ((begin (widget-field-start field)) | |
1274 (end (widget-field-end field))) | |
1275 (cond ((< (- end begin) size) | |
1276 ;; Field too small. | |
1277 (save-excursion | |
1278 (goto-char end) | |
1279 (insert-char ?\ (- (+ begin size) end)))) | |
1280 ((> (- end begin) size) | |
1281 ;; Field too large and | |
1282 (if (or (< (point) (+ begin size)) | |
1283 (> (point) end)) | |
1284 ;; Point is outside extra space. | |
1285 (setq begin (+ begin size)) | |
1286 ;; Point is within the extra space. | |
1287 (setq begin (point))) | |
1288 (save-excursion | |
1289 (goto-char end) | |
1290 (while (and (eq (preceding-char) ?\ ) | |
1291 (> (point) begin)) | |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1292 (delete-backward-char 1))))))) |
22422
1eba71735142
(widget-specify-secret): New function.
Richard M. Stallman <rms@gnu.org>
parents:
22421
diff
changeset
|
1293 (widget-specify-secret field)) |
18364
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
1294 (widget-apply field :notify field))) |
18090 | 1295 (error (debug "After Change")))) |
17334 | 1296 |
1297 ;;; Widget Functions | |
1298 ;; | |
1299 ;; These functions are used in the definition of multiple widgets. | |
1300 | |
17799 | 1301 (defun widget-parent-action (widget &optional event) |
1302 "Tell :parent of WIDGET to handle the :action. | |
1303 Optional EVENT is the event that triggered the action." | |
1304 (widget-apply (widget-get widget :parent) :action event)) | |
1305 | |
17334 | 1306 (defun widget-children-value-delete (widget) |
1307 "Delete all :children and :buttons in WIDGET." | |
1308 (mapcar 'widget-delete (widget-get widget :children)) | |
1309 (widget-put widget :children nil) | |
1310 (mapcar 'widget-delete (widget-get widget :buttons)) | |
1311 (widget-put widget :buttons nil)) | |
1312 | |
17799 | 1313 (defun widget-children-validate (widget) |
1314 "All the :children must be valid." | |
1315 (let ((children (widget-get widget :children)) | |
1316 child found) | |
1317 (while (and children (not found)) | |
1318 (setq child (car children) | |
1319 children (cdr children) | |
1320 found (widget-apply child :validate))) | |
1321 found)) | |
1322 | |
17334 | 1323 (defun widget-types-convert-widget (widget) |
1324 "Convert :args as widget types in WIDGET." | |
1325 (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) | |
1326 widget) | |
1327 | |
17799 | 1328 (defun widget-value-convert-widget (widget) |
1329 "Initialize :value from :args in WIDGET." | |
1330 (let ((args (widget-get widget :args))) | |
1331 (when args | |
1332 (widget-put widget :value (car args)) | |
1333 ;; Don't convert :value here, as this is done in `widget-convert'. | |
1334 ;; (widget-put widget :value (widget-apply widget | |
1335 ;; :value-to-internal (car args))) | |
1336 (widget-put widget :args nil))) | |
1337 widget) | |
1338 | |
1339 (defun widget-value-value-get (widget) | |
1340 "Return the :value property of WIDGET." | |
1341 (widget-get widget :value)) | |
1342 | |
17334 | 1343 ;;; The `default' Widget. |
1344 | |
1345 (define-widget 'default nil | |
1346 "Basic widget other widgets are derived from." | |
1347 :value-to-internal (lambda (widget value) value) | |
1348 :value-to-external (lambda (widget value) value) | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1349 :button-prefix 'widget-button-prefix |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1350 :button-suffix 'widget-button-suffix |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1351 :complete 'widget-default-complete |
17334 | 1352 :create 'widget-default-create |
1353 :indent nil | |
1354 :offset 0 | |
1355 :format-handler 'widget-default-format-handler | |
1356 :button-face-get 'widget-default-button-face-get | |
1357 :sample-face-get 'widget-default-sample-face-get | |
1358 :delete 'widget-default-delete | |
1359 :value-set 'widget-default-value-set | |
1360 :value-inline 'widget-default-value-inline | |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1361 :default-get 'widget-default-default-get |
17334 | 1362 :menu-tag-get 'widget-default-menu-tag-get |
1363 :validate (lambda (widget) nil) | |
1364 :active 'widget-default-active | |
1365 :activate 'widget-specify-active | |
1366 :deactivate 'widget-default-deactivate | |
17799 | 1367 :mouse-down-action (lambda (widget event) nil) |
17334 | 1368 :action 'widget-default-action |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1369 :notify 'widget-default-notify |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1370 :prompt-value 'widget-default-prompt-value) |
17334 | 1371 |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1372 (defun widget-default-complete (widget) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1373 "Call the value of the :complete-function property of WIDGET. |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1374 If that does not exists, call the value of `widget-complete-field'." |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1375 (let ((fun (widget-get widget :complete-function))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1376 (call-interactively (or fun widget-complete-field)))) |
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
1377 |
17334 | 1378 (defun widget-default-create (widget) |
1379 "Create WIDGET at point in the current buffer." | |
1380 (widget-specify-insert | |
1381 (let ((from (point)) | |
1382 button-begin button-end | |
1383 sample-begin sample-end | |
1384 doc-begin doc-end | |
1385 value-pos) | |
1386 (insert (widget-get widget :format)) | |
1387 (goto-char from) | |
1388 ;; Parse escapes in format. | |
1389 (while (re-search-forward "%\\(.\\)" nil t) | |
1390 (let ((escape (aref (match-string 1) 0))) | |
1391 (replace-match "" t t) | |
1392 (cond ((eq escape ?%) | |
1393 (insert "%")) | |
1394 ((eq escape ?\[) | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1395 (setq button-begin (point)) |
18364
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
1396 (insert (widget-get-indirect widget :button-prefix))) |
17334 | 1397 ((eq escape ?\]) |
18364
01666331d10f
Synched with 1.9930.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18361
diff
changeset
|
1398 (insert (widget-get-indirect widget :button-suffix)) |
17334 | 1399 (setq button-end (point))) |
1400 ((eq escape ?\{) | |
1401 (setq sample-begin (point))) | |
1402 ((eq escape ?\}) | |
1403 (setq sample-end (point))) | |
1404 ((eq escape ?n) | |
1405 (when (widget-get widget :indent) | |
1406 (insert "\n") | |
1407 (insert-char ? (widget-get widget :indent)))) | |
1408 ((eq escape ?t) | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1409 (let ((glyph (widget-get widget :tag-glyph)) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1410 (tag (widget-get widget :tag))) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1411 (cond (glyph |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1412 (widget-glyph-insert widget (or tag "image") glyph)) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1413 (tag |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1414 (insert tag)) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1415 (t |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1416 (let ((standard-output (current-buffer))) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1417 (princ (widget-get widget :value))))))) |
17334 | 1418 ((eq escape ?d) |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1419 (let ((doc (widget-get widget :doc))) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1420 (when doc |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1421 (setq doc-begin (point)) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1422 (insert doc) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1423 (while (eq (preceding-char) ?\n) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1424 (delete-backward-char 1)) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1425 (insert "\n") |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1426 (setq doc-end (point))))) |
17334 | 1427 ((eq escape ?v) |
1428 (if (and button-begin (not button-end)) | |
1429 (widget-apply widget :value-create) | |
1430 (setq value-pos (point)))) | |
1431 (t | |
1432 (widget-apply widget :format-handler escape))))) | |
1433 ;; Specify button, sample, and doc, and insert value. | |
1434 (and button-begin button-end | |
1435 (widget-specify-button widget button-begin button-end)) | |
1436 (and sample-begin sample-end | |
1437 (widget-specify-sample widget sample-begin sample-end)) | |
1438 (and doc-begin doc-end | |
1439 (widget-specify-doc widget doc-begin doc-end)) | |
1440 (when value-pos | |
1441 (goto-char value-pos) | |
1442 (widget-apply widget :value-create))) | |
1443 (let ((from (copy-marker (point-min))) | |
1444 (to (copy-marker (point-max)))) | |
1445 (set-marker-insertion-type from t) | |
1446 (set-marker-insertion-type to nil) | |
1447 (widget-put widget :from from) | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1448 (widget-put widget :to to))) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1449 (widget-clear-undo)) |
17334 | 1450 |
1451 (defun widget-default-format-handler (widget escape) | |
1452 ;; We recognize the %h escape by default. | |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1453 (let* ((buttons (widget-get widget :buttons))) |
17334 | 1454 (cond ((eq escape ?h) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1455 (let* ((doc-property (widget-get widget :documentation-property)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1456 (doc-try (cond ((widget-get widget :doc)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1457 ((symbolp doc-property) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1458 (documentation-property |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1459 (widget-get widget :value) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1460 doc-property)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1461 (t |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1462 (funcall doc-property |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1463 (widget-get widget :value))))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1464 (doc-text (and (stringp doc-try) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1465 (> (length doc-try) 1) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1466 doc-try)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1467 (doc-indent (widget-get widget :documentation-indent))) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1468 (when doc-text |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1469 (and (eq (preceding-char) ?\n) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1470 (widget-get widget :indent) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1471 (insert-char ? (widget-get widget :indent))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1472 ;; The `*' in the beginning is redundant. |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1473 (when (eq (aref doc-text 0) ?*) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1474 (setq doc-text (substring doc-text 1))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1475 ;; Get rid of trailing newlines. |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1476 (when (string-match "\n+\\'" doc-text) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1477 (setq doc-text (substring doc-text 0 (match-beginning 0)))) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1478 (push (widget-create-child-and-convert |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1479 widget 'documentation-string |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1480 :indent (cond ((numberp doc-indent ) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1481 doc-indent) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1482 ((null doc-indent) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1483 nil) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
1484 (t 0)) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1485 doc-text) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
1486 buttons)))) |
17334 | 1487 (t |
1488 (error "Unknown escape `%c'" escape))) | |
1489 (widget-put widget :buttons buttons))) | |
1490 | |
1491 (defun widget-default-button-face-get (widget) | |
1492 ;; Use :button-face or widget-button-face | |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
1493 (or (widget-get widget :button-face) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
1494 (let ((parent (widget-get widget :parent))) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
1495 (if parent |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
1496 (widget-apply parent :button-face-get) |
18572
f0c2a091d91f
(color-sample, editable-color): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
18562
diff
changeset
|
1497 widget-button-face)))) |
17334 | 1498 |
1499 (defun widget-default-sample-face-get (widget) | |
1500 ;; Use :sample-face. | |
1501 (widget-get widget :sample-face)) | |
1502 | |
1503 (defun widget-default-delete (widget) | |
1504 ;; Remove widget from the buffer. | |
1505 (let ((from (widget-get widget :from)) | |
1506 (to (widget-get widget :to)) | |
18089 | 1507 (inactive-overlay (widget-get widget :inactive)) |
1508 (button-overlay (widget-get widget :button-overlay)) | |
18600
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
1509 (sample-overlay (widget-get widget :sample-overlay)) |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1510 (doc-overlay (widget-get widget :doc-overlay)) |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
1511 before-change-functions |
18090 | 1512 after-change-functions |
1513 (inhibit-read-only t)) | |
17334 | 1514 (widget-apply widget :value-delete) |
18089 | 1515 (when inactive-overlay |
1516 (delete-overlay inactive-overlay)) | |
1517 (when button-overlay | |
1518 (delete-overlay button-overlay)) | |
18600
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
1519 (when sample-overlay |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
1520 (delete-overlay sample-overlay)) |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1521 (when doc-overlay |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1522 (delete-overlay doc-overlay)) |
17334 | 1523 (when (< from to) |
1524 ;; Kludge: this doesn't need to be true for empty formats. | |
1525 (delete-region from to)) | |
1526 (set-marker from nil) | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1527 (set-marker to nil)) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1528 (widget-clear-undo)) |
17334 | 1529 |
1530 (defun widget-default-value-set (widget value) | |
1531 ;; Recreate widget with new value. | |
18374
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1532 (let* ((old-pos (point)) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1533 (from (copy-marker (widget-get widget :from))) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1534 (to (copy-marker (widget-get widget :to))) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1535 (offset (if (and (<= from old-pos) (<= old-pos to)) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1536 (if (>= old-pos (1- to)) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1537 (- old-pos to 1) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1538 (- old-pos from))))) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1539 ;;??? Bug: this ought to insert the new value before deleting the old one, |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1540 ;; so that markers on either side of the value automatically |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1541 ;; stay on the same side. -- rms. |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1542 (save-excursion |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1543 (goto-char (widget-get widget :from)) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1544 (widget-apply widget :delete) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1545 (widget-put widget :value value) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1546 (widget-apply widget :create)) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1547 (if offset |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1548 (if (< offset 0) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1549 (goto-char (+ (widget-get widget :to) offset 1)) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
1550 (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) |
17334 | 1551 |
1552 (defun widget-default-value-inline (widget) | |
1553 ;; Wrap value in a list unless it is inline. | |
1554 (if (widget-get widget :inline) | |
1555 (widget-value widget) | |
1556 (list (widget-value widget)))) | |
1557 | |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1558 (defun widget-default-default-get (widget) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1559 ;; Get `:value'. |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1560 (widget-get widget :value)) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1561 |
17334 | 1562 (defun widget-default-menu-tag-get (widget) |
1563 ;; Use tag or value for menus. | |
1564 (or (widget-get widget :menu-tag) | |
1565 (widget-get widget :tag) | |
1566 (widget-princ-to-string (widget-get widget :value)))) | |
1567 | |
1568 (defun widget-default-active (widget) | |
1569 "Return t iff this widget active (user modifiable)." | |
1570 (and (not (widget-get widget :inactive)) | |
1571 (let ((parent (widget-get widget :parent))) | |
1572 (or (null parent) | |
1573 (widget-apply parent :active))))) | |
1574 | |
1575 (defun widget-default-deactivate (widget) | |
1576 "Make WIDGET inactive for user modifications." | |
1577 (widget-specify-inactive widget | |
1578 (widget-get widget :from) | |
1579 (widget-get widget :to))) | |
1580 | |
1581 (defun widget-default-action (widget &optional event) | |
1582 ;; Notify the parent when a widget change | |
1583 (let ((parent (widget-get widget :parent))) | |
1584 (when parent | |
1585 (widget-apply parent :notify widget event)))) | |
1586 | |
1587 (defun widget-default-notify (widget child &optional event) | |
1588 ;; Pass notification to parent. | |
1589 (widget-default-action widget event)) | |
1590 | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1591 (defun widget-default-prompt-value (widget prompt value unbound) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1592 ;; Read an arbitrary value. Stolen from `set-variable'. |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1593 ;; (let ((initial (if unbound |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1594 ;; nil |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1595 ;; ;; It would be nice if we could do a `(cons val 1)' here. |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1596 ;; (prin1-to-string (custom-quote value)))))) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1597 (eval-minibuffer prompt )) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
1598 |
17334 | 1599 ;;; The `item' Widget. |
1600 | |
1601 (define-widget 'item 'default | |
1602 "Constant items for inclusion in other widgets." | |
17799 | 1603 :convert-widget 'widget-value-convert-widget |
17334 | 1604 :value-create 'widget-item-value-create |
1605 :value-delete 'ignore | |
17799 | 1606 :value-get 'widget-value-value-get |
17334 | 1607 :match 'widget-item-match |
1608 :match-inline 'widget-item-match-inline | |
1609 :action 'widget-item-action | |
1610 :format "%t\n") | |
1611 | |
1612 (defun widget-item-value-create (widget) | |
1613 ;; Insert the printed representation of the value. | |
1614 (let ((standard-output (current-buffer))) | |
1615 (princ (widget-get widget :value)))) | |
1616 | |
1617 (defun widget-item-match (widget value) | |
1618 ;; Match if the value is the same. | |
1619 (equal (widget-get widget :value) value)) | |
1620 | |
1621 (defun widget-item-match-inline (widget values) | |
1622 ;; Match if the value is the same. | |
1623 (let ((value (widget-get widget :value))) | |
1624 (and (listp value) | |
1625 (<= (length value) (length values)) | |
18056
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
1626 (let ((head (widget-sublist values 0 (length value)))) |
17334 | 1627 (and (equal head value) |
18056
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
1628 (cons head (widget-sublist values (length value)))))))) |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
1629 |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
1630 (defun widget-sublist (list start &optional end) |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
1631 "Return the sublist of LIST from START to END. |
f8591273bf79
(widget-default-format-handler): Don't use push.
Richard M. Stallman <rms@gnu.org>
parents:
18055
diff
changeset
|
1632 If END is omitted, it defaults to the length of LIST." |
18090 | 1633 (if (> start 0) (setq list (nthcdr start list))) |
1634 (if end | |
1635 (if (<= end start) | |
1636 nil | |
1637 (setq list (copy-sequence list)) | |
1638 (setcdr (nthcdr (- end start 1) list) nil) | |
1639 list) | |
1640 (copy-sequence list))) | |
17334 | 1641 |
1642 (defun widget-item-action (widget &optional event) | |
1643 ;; Just notify itself. | |
1644 (widget-apply widget :notify widget event)) | |
1645 | |
1646 ;;; The `push-button' Widget. | |
1647 | |
1648 (defcustom widget-push-button-gui t | |
1649 "If non nil, use GUI push buttons when available." | |
1650 :group 'widgets | |
1651 :type 'boolean) | |
1652 | |
1653 ;; Cache already created GUI objects. | |
1654 (defvar widget-push-button-cache nil) | |
1655 | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1656 (defcustom widget-push-button-prefix "[" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1657 "String used as prefix for buttons." |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1658 :type 'string |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1659 :group 'widget-button) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1660 |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1661 (defcustom widget-push-button-suffix "]" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1662 "String used as suffix for buttons." |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1663 :type 'string |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1664 :group 'widget-button) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1665 |
17334 | 1666 (define-widget 'push-button 'item |
1667 "A pushable button." | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1668 :button-prefix "" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1669 :button-suffix "" |
17334 | 1670 :value-create 'widget-push-button-value-create |
1671 :format "%[%v%]") | |
1672 | |
1673 (defun widget-push-button-value-create (widget) | |
1674 ;; Insert text representing the `on' and `off' states. | |
1675 (let* ((tag (or (widget-get widget :tag) | |
1676 (widget-get widget :value))) | |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1677 (tag-glyph (widget-get widget :tag-glyph)) |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1678 (text (concat widget-push-button-prefix |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1679 tag widget-push-button-suffix)) |
17334 | 1680 (gui (cdr (assoc tag widget-push-button-cache)))) |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1681 (cond (tag-glyph |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1682 (widget-glyph-insert widget text tag-glyph)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1683 ((and (fboundp 'make-gui-button) |
17334 | 1684 (fboundp 'make-glyph) |
1685 widget-push-button-gui | |
1686 (fboundp 'device-on-window-system-p) | |
1687 (device-on-window-system-p) | |
1688 (string-match "XEmacs" emacs-version)) | |
18451
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1689 (unless gui |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1690 (setq gui (make-gui-button tag 'widget-gui-action widget)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1691 (push (cons tag gui) widget-push-button-cache)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1692 (widget-glyph-insert-glyph widget |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1693 (make-glyph |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1694 (list (nth 0 (aref gui 1)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1695 (vector 'string ':data text))) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1696 (make-glyph |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1697 (list (nth 1 (aref gui 1)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1698 (vector 'string ':data text))) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1699 (make-glyph |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1700 (list (nth 2 (aref gui 1)) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1701 (vector 'string ':data text))))) |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1702 (t |
8eb08560287b
Synched with 1.9936.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18438
diff
changeset
|
1703 (insert text))))) |
17334 | 1704 |
1705 (defun widget-gui-action (widget) | |
1706 "Apply :action for WIDGET." | |
1707 (widget-apply-action widget (this-command-keys))) | |
1708 | |
1709 ;;; The `link' Widget. | |
1710 | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1711 (defcustom widget-link-prefix "[" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1712 "String used as prefix for links." |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1713 :type 'string |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1714 :group 'widget-button) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1715 |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1716 (defcustom widget-link-suffix "]" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1717 "String used as suffix for links." |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1718 :type 'string |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1719 :group 'widget-button) |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1720 |
17334 | 1721 (define-widget 'link 'item |
1722 "An embedded link." | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1723 :button-prefix 'widget-link-prefix |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1724 :button-suffix 'widget-link-suffix |
17334 | 1725 :help-echo "Follow the link." |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1726 :format "%[%t%]") |
17334 | 1727 |
1728 ;;; The `info-link' Widget. | |
1729 | |
1730 (define-widget 'info-link 'link | |
1731 "A link to an info file." | |
1732 :action 'widget-info-link-action) | |
1733 | |
1734 (defun widget-info-link-action (widget &optional event) | |
1735 "Open the info node specified by WIDGET." | |
17799 | 1736 (Info-goto-node (widget-value widget))) |
17334 | 1737 |
1738 ;;; The `url-link' Widget. | |
1739 | |
1740 (define-widget 'url-link 'link | |
1741 "A link to an www page." | |
1742 :action 'widget-url-link-action) | |
1743 | |
1744 (defun widget-url-link-action (widget &optional event) | |
1745 "Open the url specified by WIDGET." | |
21068
cb35e7350402
Use browse-url directly.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
20466
diff
changeset
|
1746 (browse-url (widget-value widget))) |
17334 | 1747 |
20073 | 1748 ;;; The `function-link' Widget. |
1749 | |
1750 (define-widget 'function-link 'link | |
1751 "A link to an Emacs function." | |
1752 :action 'widget-function-link-action) | |
1753 | |
1754 (defun widget-function-link-action (widget &optional event) | |
1755 "Show the function specified by WIDGET." | |
1756 (describe-function (widget-value widget))) | |
1757 | |
1758 ;;; The `variable-link' Widget. | |
1759 | |
1760 (define-widget 'variable-link 'link | |
1761 "A link to an Emacs variable." | |
1762 :action 'widget-variable-link-action) | |
1763 | |
1764 (defun widget-variable-link-action (widget &optional event) | |
1765 "Show the variable specified by WIDGET." | |
1766 (describe-variable (widget-value widget))) | |
1767 | |
18598
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1768 ;;; The `file-link' Widget. |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1769 |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1770 (define-widget 'file-link 'link |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1771 "A link to a file." |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1772 :action 'widget-file-link-action) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1773 |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1774 (defun widget-file-link-action (widget &optional event) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1775 "Find the file specified by WIDGET." |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1776 (find-file (widget-value widget))) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1777 |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1778 ;;; The `emacs-library-link' Widget. |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1779 |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1780 (define-widget 'emacs-library-link 'link |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1781 "A link to an Emacs Lisp library file." |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1782 :action 'widget-emacs-library-link-action) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1783 |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1784 (defun widget-emacs-library-link-action (widget &optional event) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1785 "Find the Emacs Library file specified by WIDGET." |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1786 (find-file (locate-library (widget-value widget)))) |
e12b4c195b2b
Synched with 1.9944.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18572
diff
changeset
|
1787 |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1788 ;;; The `emacs-commentary-link' Widget. |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1789 |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1790 (define-widget 'emacs-commentary-link 'link |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1791 "A link to Commentary in an Emacs Lisp library file." |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1792 :action 'widget-emacs-commentary-link-action) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1793 |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1794 (defun widget-emacs-commentary-link-action (widget &optional event) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1795 "Find the Commentary section of the Emacs file specified by WIDGET." |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1796 (finder-commentary (widget-value widget))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
1797 |
17334 | 1798 ;;; The `editable-field' Widget. |
1799 | |
1800 (define-widget 'editable-field 'default | |
1801 "An editable text field." | |
17799 | 1802 :convert-widget 'widget-value-convert-widget |
17334 | 1803 :keymap widget-field-keymap |
1804 :format "%v" | |
1805 :value "" | |
17799 | 1806 :prompt-internal 'widget-field-prompt-internal |
1807 :prompt-history 'widget-field-history | |
1808 :prompt-value 'widget-field-prompt-value | |
17334 | 1809 :action 'widget-field-action |
1810 :validate 'widget-field-validate | |
1811 :valid-regexp "" | |
1812 :error "No match" | |
1813 :value-create 'widget-field-value-create | |
1814 :value-delete 'widget-field-value-delete | |
1815 :value-get 'widget-field-value-get | |
1816 :match 'widget-field-match) | |
1817 | |
17799 | 1818 (defvar widget-field-history nil |
1819 "History of field minibuffer edits.") | |
1820 | |
1821 (defun widget-field-prompt-internal (widget prompt initial history) | |
1822 ;; Read string for WIDGET promptinhg with PROMPT. | |
1823 ;; INITIAL is the initial input and HISTORY is a symbol containing | |
1824 ;; the earlier input. | |
1825 (read-string prompt initial history)) | |
1826 | |
1827 (defun widget-field-prompt-value (widget prompt value unbound) | |
1828 ;; Prompt for a string. | |
1829 (let ((initial (if unbound | |
1830 nil | |
1831 (cons (widget-apply widget :value-to-internal | |
1832 value) 0))) | |
1833 (history (widget-get widget :prompt-history))) | |
1834 (let ((answer (widget-apply widget | |
1835 :prompt-internal prompt initial history))) | |
1836 (widget-apply widget :value-to-external answer)))) | |
17334 | 1837 |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
1838 (defvar widget-edit-functions nil) |
18429
8326843eefd9
(widget-edit-hook): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18374
diff
changeset
|
1839 |
17334 | 1840 (defun widget-field-action (widget &optional event) |
18372
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
1841 ;; Move to next field. |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
1842 (widget-forward 1) |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
1843 (run-hook-with-args 'widget-edit-functions widget)) |
17334 | 1844 |
1845 (defun widget-field-validate (widget) | |
1846 ;; Valid if the content matches `:valid-regexp'. | |
1847 (save-excursion | |
1848 (let ((value (widget-apply widget :value-get)) | |
1849 (regexp (widget-get widget :valid-regexp))) | |
1850 (if (string-match regexp value) | |
1851 nil | |
1852 widget)))) | |
1853 | |
1854 (defun widget-field-value-create (widget) | |
1855 ;; Create an editable text field. | |
1856 (let ((size (widget-get widget :size)) | |
1857 (value (widget-get widget :value)) | |
18090 | 1858 (from (point)) |
18562
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
1859 ;; This is changed to a real overlay in `widget-setup'. We |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
1860 ;; need the end points to behave differently until |
e22e2a4e683a
Synched with 1.9942.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18461
diff
changeset
|
1861 ;; `widget-setup' is called. |
18090 | 1862 (overlay (cons (make-marker) (make-marker)))) |
1863 (widget-put widget :field-overlay overlay) | |
17334 | 1864 (insert value) |
1865 (and size | |
1866 (< (length value) size) | |
1867 (insert-char ?\ (- size (length value)))) | |
1868 (unless (memq widget widget-field-list) | |
1869 (setq widget-field-new (cons widget widget-field-new))) | |
18090 | 1870 (move-marker (cdr overlay) (point)) |
1871 (set-marker-insertion-type (cdr overlay) nil) | |
1872 (when (null size) | |
1873 (insert ?\n)) | |
1874 (move-marker (car overlay) from) | |
1875 (set-marker-insertion-type (car overlay) t))) | |
17334 | 1876 |
1877 (defun widget-field-value-delete (widget) | |
1878 ;; Remove the widget from the list of active editing fields. | |
1879 (setq widget-field-list (delq widget widget-field-list)) | |
1880 ;; These are nil if the :format string doesn't contain `%v'. | |
18090 | 1881 (let ((overlay (widget-get widget :field-overlay))) |
1882 (when overlay | |
1883 (delete-overlay overlay)))) | |
17334 | 1884 |
1885 (defun widget-field-value-get (widget) | |
1886 ;; Return current text in editing field. | |
18090 | 1887 (let ((from (widget-field-start widget)) |
1888 (to (widget-field-end widget)) | |
1889 (buffer (widget-field-buffer widget)) | |
17334 | 1890 (size (widget-get widget :size)) |
1891 (secret (widget-get widget :secret)) | |
1892 (old (current-buffer))) | |
1893 (if (and from to) | |
1894 (progn | |
18090 | 1895 (set-buffer buffer) |
17334 | 1896 (while (and size |
1897 (not (zerop size)) | |
1898 (> to from) | |
1899 (eq (char-after (1- to)) ?\ )) | |
1900 (setq to (1- to))) | |
1901 (let ((result (buffer-substring-no-properties from to))) | |
1902 (when secret | |
1903 (let ((index 0)) | |
1904 (while (< (+ from index) to) | |
1905 (aset result index | |
18090 | 1906 (get-char-property (+ from index) 'secret)) |
17334 | 1907 (setq index (1+ index))))) |
1908 (set-buffer old) | |
1909 result)) | |
1910 (widget-get widget :value)))) | |
1911 | |
1912 (defun widget-field-match (widget value) | |
1913 ;; Match any string. | |
1914 (stringp value)) | |
1915 | |
1916 ;;; The `text' Widget. | |
1917 | |
1918 (define-widget 'text 'editable-field | |
1919 :keymap widget-text-keymap | |
1920 "A multiline text area.") | |
1921 | |
1922 ;;; The `menu-choice' Widget. | |
1923 | |
1924 (define-widget 'menu-choice 'default | |
1925 "A menu of options." | |
1926 :convert-widget 'widget-types-convert-widget | |
1927 :format "%[%t%]: %v" | |
1928 :case-fold t | |
1929 :tag "choice" | |
1930 :void '(item :format "invalid (%t)\n") | |
1931 :value-create 'widget-choice-value-create | |
1932 :value-delete 'widget-children-value-delete | |
1933 :value-get 'widget-choice-value-get | |
1934 :value-inline 'widget-choice-value-inline | |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1935 :default-get 'widget-choice-default-get |
17799 | 1936 :mouse-down-action 'widget-choice-mouse-down-action |
17334 | 1937 :action 'widget-choice-action |
1938 :error "Make a choice" | |
1939 :validate 'widget-choice-validate | |
1940 :match 'widget-choice-match | |
1941 :match-inline 'widget-choice-match-inline) | |
1942 | |
1943 (defun widget-choice-value-create (widget) | |
1944 ;; Insert the first choice that matches the value. | |
1945 (let ((value (widget-get widget :value)) | |
1946 (args (widget-get widget :args)) | |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1947 (explicit (widget-get widget :explicit-choice)) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1948 (explicit-value (widget-get widget :explicit-choice-value)) |
17334 | 1949 current) |
24317
971fec299b71
(widget-choice-value-create): Use `equal' instead of `eq'.
Richard M. Stallman <rms@gnu.org>
parents:
24134
diff
changeset
|
1950 (if (and explicit (equal value explicit-value)) |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1951 (progn |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1952 ;; If the user specified the choice for this value, |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1953 ;; respect that choice as long as the value is the same. |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1954 (widget-put widget :children (list (widget-create-child-value |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1955 widget explicit value))) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1956 (widget-put widget :choice explicit)) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1957 (while args |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1958 (setq current (car args) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1959 args (cdr args)) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1960 (when (widget-apply current :match value) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1961 (widget-put widget :children (list (widget-create-child-value |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1962 widget current value))) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1963 (widget-put widget :choice current) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1964 (setq args nil |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1965 current nil))) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1966 (when current |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1967 (let ((void (widget-get widget :void))) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1968 (widget-put widget :children (list (widget-create-child-and-convert |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1969 widget void :value value))) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
1970 (widget-put widget :choice void)))))) |
17334 | 1971 |
1972 (defun widget-choice-value-get (widget) | |
1973 ;; Get value of the child widget. | |
1974 (widget-value (car (widget-get widget :children)))) | |
1975 | |
1976 (defun widget-choice-value-inline (widget) | |
1977 ;; Get value of the child widget. | |
1978 (widget-apply (car (widget-get widget :children)) :value-inline)) | |
1979 | |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1980 (defun widget-choice-default-get (widget) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1981 ;; Get default for the first choice. |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1982 (widget-default-get (car (widget-get widget :args)))) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
1983 |
17799 | 1984 (defcustom widget-choice-toggle nil |
1985 "If non-nil, a binary choice will just toggle between the values. | |
1986 Otherwise, the user will explicitly have to choose between the values | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
1987 when he invoked the menu." |
17799 | 1988 :type 'boolean |
1989 :group 'widgets) | |
1990 | |
1991 (defun widget-choice-mouse-down-action (widget &optional event) | |
1992 ;; Return non-nil if we need a menu. | |
1993 (let ((args (widget-get widget :args)) | |
1994 (old (widget-get widget :choice))) | |
1995 (cond ((not window-system) | |
1996 ;; No place to pop up a menu. | |
1997 nil) | |
1998 ((not (or (fboundp 'x-popup-menu) (fboundp 'popup-menu))) | |
1999 ;; No way to pop up a menu. | |
2000 nil) | |
2001 ((< (length args) 2) | |
2002 ;; Empty or singleton list, just return the value. | |
2003 nil) | |
2004 ((> (length args) widget-menu-max-size) | |
2005 ;; Too long, prompt. | |
2006 nil) | |
2007 ((> (length args) 2) | |
2008 ;; Reasonable sized list, use menu. | |
2009 t) | |
2010 ((and widget-choice-toggle (memq old args)) | |
2011 ;; We toggle. | |
2012 nil) | |
2013 (t | |
2014 ;; Ask which of the two. | |
2015 t)))) | |
2016 | |
17334 | 2017 (defun widget-choice-action (widget &optional event) |
2018 ;; Make a choice. | |
2019 (let ((args (widget-get widget :args)) | |
2020 (old (widget-get widget :choice)) | |
2021 (tag (widget-apply widget :menu-tag-get)) | |
2022 (completion-ignore-case (widget-get widget :case-fold)) | |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2023 this-explicit |
17334 | 2024 current choices) |
2025 ;; Remember old value. | |
2026 (if (and old (not (widget-apply widget :validate))) | |
2027 (let* ((external (widget-value widget)) | |
2028 (internal (widget-apply old :value-to-internal external))) | |
2029 (widget-put old :value internal))) | |
2030 ;; Find new choice. | |
2031 (setq current | |
2032 (cond ((= (length args) 0) | |
2033 nil) | |
2034 ((= (length args) 1) | |
2035 (nth 0 args)) | |
17799 | 2036 ((and widget-choice-toggle |
2037 (= (length args) 2) | |
17334 | 2038 (memq old args)) |
2039 (if (eq old (nth 0 args)) | |
2040 (nth 1 args) | |
2041 (nth 0 args))) | |
2042 (t | |
2043 (while args | |
2044 (setq current (car args) | |
2045 args (cdr args)) | |
2046 (setq choices | |
2047 (cons (cons (widget-apply current :menu-tag-get) | |
2048 current) | |
2049 choices))) | |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2050 (setq this-explicit t) |
17334 | 2051 (widget-choose tag (reverse choices) event)))) |
18374
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
2052 (when current |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2053 ;; If this was an explicit user choice, |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2054 ;; record the choice, and the record the value it was made for. |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2055 ;; widget-choice-value-create will respect this choice, |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2056 ;; as long as the value is the same. |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2057 (when this-explicit |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2058 (widget-put widget :explicit-choice current) |
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
2059 (widget-put widget :explicit-choice-value (widget-get widget :value))) |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2060 (let ((value (widget-default-get current))) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2061 (widget-value-set widget |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2062 (widget-apply current :value-to-external value))) |
18374
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
2063 (widget-setup) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
2064 (widget-apply widget :notify widget event))) |
18461
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
2065 (run-hook-with-args 'widget-edit-functions widget)) |
17334 | 2066 |
2067 (defun widget-choice-validate (widget) | |
2068 ;; Valid if we have made a valid choice. | |
2069 (let ((void (widget-get widget :void)) | |
2070 (choice (widget-get widget :choice)) | |
2071 (child (car (widget-get widget :children)))) | |
2072 (if (eq void choice) | |
2073 widget | |
2074 (widget-apply child :validate)))) | |
2075 | |
2076 (defun widget-choice-match (widget value) | |
2077 ;; Matches if one of the choices matches. | |
2078 (let ((args (widget-get widget :args)) | |
2079 current found) | |
2080 (while (and args (not found)) | |
2081 (setq current (car args) | |
2082 args (cdr args) | |
2083 found (widget-apply current :match value))) | |
2084 found)) | |
2085 | |
2086 (defun widget-choice-match-inline (widget values) | |
2087 ;; Matches if one of the choices matches. | |
2088 (let ((args (widget-get widget :args)) | |
2089 current found) | |
2090 (while (and args (null found)) | |
2091 (setq current (car args) | |
2092 args (cdr args) | |
2093 found (widget-match-inline current values))) | |
2094 found)) | |
2095 | |
2096 ;;; The `toggle' Widget. | |
2097 | |
2098 (define-widget 'toggle 'item | |
2099 "Toggle between two states." | |
2100 :format "%[%v%]\n" | |
2101 :value-create 'widget-toggle-value-create | |
2102 :action 'widget-toggle-action | |
2103 :match (lambda (widget value) t) | |
2104 :on "on" | |
2105 :off "off") | |
2106 | |
2107 (defun widget-toggle-value-create (widget) | |
2108 ;; Insert text representing the `on' and `off' states. | |
2109 (if (widget-value widget) | |
2110 (widget-glyph-insert widget | |
2111 (widget-get widget :on) | |
2112 (widget-get widget :on-glyph)) | |
2113 (widget-glyph-insert widget | |
2114 (widget-get widget :off) | |
2115 (widget-get widget :off-glyph)))) | |
2116 | |
2117 (defun widget-toggle-action (widget &optional event) | |
2118 ;; Toggle value. | |
18374
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
2119 (widget-value-set widget (not (widget-value widget))) |
201d766770fd
(widget-default-value-set): Preserve point here.
Richard M. Stallman <rms@gnu.org>
parents:
18372
diff
changeset
|
2120 (widget-apply widget :notify widget event) |
18461
35976f73432d
(widget-choice-action): Use widget-edit-functions.
Richard M. Stallman <rms@gnu.org>
parents:
18451
diff
changeset
|
2121 (run-hook-with-args 'widget-edit-functions widget)) |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2122 |
17334 | 2123 ;;; The `checkbox' Widget. |
2124 | |
2125 (define-widget 'checkbox 'toggle | |
2126 "A checkbox toggle." | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
2127 :button-suffix "" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
2128 :button-prefix "" |
17334 | 2129 :format "%[%v%]" |
2130 :on "[X]" | |
2131 :on-glyph "check1" | |
2132 :off "[ ]" | |
2133 :off-glyph "check0" | |
2134 :action 'widget-checkbox-action) | |
2135 | |
2136 (defun widget-checkbox-action (widget &optional event) | |
2137 "Toggle checkbox, notify parent, and set active state of sibling." | |
2138 (widget-toggle-action widget event) | |
2139 (let ((sibling (widget-get-sibling widget))) | |
2140 (when sibling | |
2141 (if (widget-value widget) | |
2142 (widget-apply sibling :activate) | |
2143 (widget-apply sibling :deactivate))))) | |
2144 | |
2145 ;;; The `checklist' Widget. | |
2146 | |
2147 (define-widget 'checklist 'default | |
2148 "A multiple choice widget." | |
2149 :convert-widget 'widget-types-convert-widget | |
2150 :format "%v" | |
2151 :offset 4 | |
2152 :entry-format "%b %v" | |
2153 :menu-tag "checklist" | |
2154 :greedy nil | |
2155 :value-create 'widget-checklist-value-create | |
2156 :value-delete 'widget-children-value-delete | |
2157 :value-get 'widget-checklist-value-get | |
2158 :validate 'widget-checklist-validate | |
2159 :match 'widget-checklist-match | |
2160 :match-inline 'widget-checklist-match-inline) | |
2161 | |
2162 (defun widget-checklist-value-create (widget) | |
2163 ;; Insert all values | |
2164 (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) | |
2165 (args (widget-get widget :args))) | |
2166 (while args | |
2167 (widget-checklist-add-item widget (car args) (assq (car args) alist)) | |
2168 (setq args (cdr args))) | |
2169 (widget-put widget :children (nreverse (widget-get widget :children))))) | |
2170 | |
2171 (defun widget-checklist-add-item (widget type chosen) | |
2172 ;; Create checklist item in WIDGET of type TYPE. | |
2173 ;; If the item is checked, CHOSEN is a cons whose cdr is the value. | |
2174 (and (eq (preceding-char) ?\n) | |
2175 (widget-get widget :indent) | |
2176 (insert-char ? (widget-get widget :indent))) | |
2177 (widget-specify-insert | |
2178 (let* ((children (widget-get widget :children)) | |
2179 (buttons (widget-get widget :buttons)) | |
2180 (button-args (or (widget-get type :sibling-args) | |
2181 (widget-get widget :button-args))) | |
2182 (from (point)) | |
2183 child button) | |
2184 (insert (widget-get widget :entry-format)) | |
2185 (goto-char from) | |
2186 ;; Parse % escapes in format. | |
2187 (while (re-search-forward "%\\([bv%]\\)" nil t) | |
2188 (let ((escape (aref (match-string 1) 0))) | |
2189 (replace-match "" t t) | |
2190 (cond ((eq escape ?%) | |
2191 (insert "%")) | |
2192 ((eq escape ?b) | |
2193 (setq button (apply 'widget-create-child-and-convert | |
2194 widget 'checkbox | |
2195 :value (not (null chosen)) | |
2196 button-args))) | |
2197 ((eq escape ?v) | |
2198 (setq child | |
2199 (cond ((not chosen) | |
2200 (let ((child (widget-create-child widget type))) | |
2201 (widget-apply child :deactivate) | |
2202 child)) | |
2203 ((widget-get type :inline) | |
2204 (widget-create-child-value | |
2205 widget type (cdr chosen))) | |
2206 (t | |
2207 (widget-create-child-value | |
2208 widget type (car (cdr chosen))))))) | |
2209 (t | |
2210 (error "Unknown escape `%c'" escape))))) | |
2211 ;; Update properties. | |
2212 (and button child (widget-put child :button button)) | |
2213 (and button (widget-put widget :buttons (cons button buttons))) | |
2214 (and child (widget-put widget :children (cons child children)))))) | |
2215 | |
2216 (defun widget-checklist-match (widget values) | |
2217 ;; All values must match a type in the checklist. | |
2218 (and (listp values) | |
2219 (null (cdr (widget-checklist-match-inline widget values))))) | |
2220 | |
2221 (defun widget-checklist-match-inline (widget values) | |
2222 ;; Find the values which match a type in the checklist. | |
2223 (let ((greedy (widget-get widget :greedy)) | |
17535
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
2224 (args (copy-sequence (widget-get widget :args))) |
17334 | 2225 found rest) |
2226 (while values | |
2227 (let ((answer (widget-checklist-match-up args values))) | |
2228 (cond (answer | |
2229 (let ((vals (widget-match-inline answer values))) | |
2230 (setq found (append found (car vals)) | |
2231 values (cdr vals) | |
2232 args (delq answer args)))) | |
2233 (greedy | |
2234 (setq rest (append rest (list (car values))) | |
2235 values (cdr values))) | |
2236 (t | |
2237 (setq rest (append rest values) | |
2238 values nil))))) | |
2239 (cons found rest))) | |
2240 | |
2241 (defun widget-checklist-match-find (widget vals) | |
2242 ;; Find the vals which match a type in the checklist. | |
2243 ;; Return an alist of (TYPE MATCH). | |
2244 (let ((greedy (widget-get widget :greedy)) | |
17535
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
2245 (args (copy-sequence (widget-get widget :args))) |
17334 | 2246 found) |
2247 (while vals | |
2248 (let ((answer (widget-checklist-match-up args vals))) | |
2249 (cond (answer | |
2250 (let ((match (widget-match-inline answer vals))) | |
2251 (setq found (cons (cons answer (car match)) found) | |
2252 vals (cdr match) | |
2253 args (delq answer args)))) | |
2254 (greedy | |
2255 (setq vals (cdr vals))) | |
2256 (t | |
2257 (setq vals nil))))) | |
2258 found)) | |
2259 | |
2260 (defun widget-checklist-match-up (args vals) | |
2261 ;; Rerturn the first type from ARGS that matches VALS. | |
2262 (let (current found) | |
2263 (while (and args (null found)) | |
2264 (setq current (car args) | |
2265 args (cdr args) | |
2266 found (widget-match-inline current vals))) | |
2267 (if found | |
2268 current | |
2269 nil))) | |
2270 | |
2271 (defun widget-checklist-value-get (widget) | |
2272 ;; The values of all selected items. | |
2273 (let ((children (widget-get widget :children)) | |
2274 child result) | |
2275 (while children | |
2276 (setq child (car children) | |
2277 children (cdr children)) | |
2278 (if (widget-value (widget-get child :button)) | |
2279 (setq result (append result (widget-apply child :value-inline))))) | |
2280 result)) | |
2281 | |
2282 (defun widget-checklist-validate (widget) | |
2283 ;; Ticked chilren must be valid. | |
2284 (let ((children (widget-get widget :children)) | |
2285 child button found) | |
2286 (while (and children (not found)) | |
2287 (setq child (car children) | |
2288 children (cdr children) | |
2289 button (widget-get child :button) | |
2290 found (and (widget-value button) | |
2291 (widget-apply child :validate)))) | |
2292 found)) | |
2293 | |
2294 ;;; The `option' Widget | |
2295 | |
2296 (define-widget 'option 'checklist | |
2297 "An widget with an optional item." | |
2298 :inline t) | |
2299 | |
2300 ;;; The `choice-item' Widget. | |
2301 | |
2302 (define-widget 'choice-item 'item | |
2303 "Button items that delegate action events to their parents." | |
17799 | 2304 :action 'widget-parent-action |
17334 | 2305 :format "%[%t%] \n") |
2306 | |
2307 ;;; The `radio-button' Widget. | |
2308 | |
2309 (define-widget 'radio-button 'toggle | |
2310 "A radio button for use in the `radio' widget." | |
2311 :notify 'widget-radio-button-notify | |
2312 :format "%[%v%]" | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
2313 :button-suffix "" |
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
2314 :button-prefix "" |
17334 | 2315 :on "(*)" |
2316 :on-glyph "radio1" | |
2317 :off "( )" | |
2318 :off-glyph "radio0") | |
2319 | |
2320 (defun widget-radio-button-notify (widget child &optional event) | |
2321 ;; Tell daddy. | |
2322 (widget-apply (widget-get widget :parent) :action widget event)) | |
2323 | |
2324 ;;; The `radio-button-choice' Widget. | |
2325 | |
2326 (define-widget 'radio-button-choice 'default | |
2327 "Select one of multiple options." | |
2328 :convert-widget 'widget-types-convert-widget | |
2329 :offset 4 | |
2330 :format "%v" | |
2331 :entry-format "%b %v" | |
2332 :menu-tag "radio" | |
2333 :value-create 'widget-radio-value-create | |
2334 :value-delete 'widget-children-value-delete | |
2335 :value-get 'widget-radio-value-get | |
2336 :value-inline 'widget-radio-value-inline | |
2337 :value-set 'widget-radio-value-set | |
2338 :error "You must push one of the buttons" | |
2339 :validate 'widget-radio-validate | |
2340 :match 'widget-choice-match | |
2341 :match-inline 'widget-choice-match-inline | |
2342 :action 'widget-radio-action) | |
2343 | |
2344 (defun widget-radio-value-create (widget) | |
2345 ;; Insert all values | |
2346 (let ((args (widget-get widget :args)) | |
2347 arg) | |
2348 (while args | |
2349 (setq arg (car args) | |
2350 args (cdr args)) | |
2351 (widget-radio-add-item widget arg)))) | |
2352 | |
2353 (defun widget-radio-add-item (widget type) | |
2354 "Add to radio widget WIDGET a new radio button item of type TYPE." | |
2355 ;; (setq type (widget-convert type)) | |
2356 (and (eq (preceding-char) ?\n) | |
2357 (widget-get widget :indent) | |
2358 (insert-char ? (widget-get widget :indent))) | |
2359 (widget-specify-insert | |
2360 (let* ((value (widget-get widget :value)) | |
2361 (children (widget-get widget :children)) | |
2362 (buttons (widget-get widget :buttons)) | |
2363 (button-args (or (widget-get type :sibling-args) | |
2364 (widget-get widget :button-args))) | |
2365 (from (point)) | |
2366 (chosen (and (null (widget-get widget :choice)) | |
2367 (widget-apply type :match value))) | |
2368 child button) | |
2369 (insert (widget-get widget :entry-format)) | |
2370 (goto-char from) | |
2371 ;; Parse % escapes in format. | |
2372 (while (re-search-forward "%\\([bv%]\\)" nil t) | |
2373 (let ((escape (aref (match-string 1) 0))) | |
2374 (replace-match "" t t) | |
2375 (cond ((eq escape ?%) | |
2376 (insert "%")) | |
2377 ((eq escape ?b) | |
2378 (setq button (apply 'widget-create-child-and-convert | |
2379 widget 'radio-button | |
2380 :value (not (null chosen)) | |
2381 button-args))) | |
2382 ((eq escape ?v) | |
2383 (setq child (if chosen | |
2384 (widget-create-child-value | |
2385 widget type value) | |
2386 (widget-create-child widget type))) | |
2387 (unless chosen | |
2388 (widget-apply child :deactivate))) | |
2389 (t | |
2390 (error "Unknown escape `%c'" escape))))) | |
2391 ;; Update properties. | |
2392 (when chosen | |
2393 (widget-put widget :choice type)) | |
2394 (when button | |
2395 (widget-put child :button button) | |
2396 (widget-put widget :buttons (nconc buttons (list button)))) | |
2397 (when child | |
2398 (widget-put widget :children (nconc children (list child)))) | |
2399 child))) | |
2400 | |
2401 (defun widget-radio-value-get (widget) | |
2402 ;; Get value of the child widget. | |
2403 (let ((chosen (widget-radio-chosen widget))) | |
2404 (and chosen (widget-value chosen)))) | |
2405 | |
2406 (defun widget-radio-chosen (widget) | |
2407 "Return the widget representing the chosen radio button." | |
2408 (let ((children (widget-get widget :children)) | |
2409 current found) | |
2410 (while children | |
2411 (setq current (car children) | |
2412 children (cdr children)) | |
2413 (let* ((button (widget-get current :button)) | |
2414 (value (widget-apply button :value-get))) | |
2415 (when value | |
2416 (setq found current | |
2417 children nil)))) | |
2418 found)) | |
2419 | |
2420 (defun widget-radio-value-inline (widget) | |
2421 ;; Get value of the child widget. | |
2422 (let ((children (widget-get widget :children)) | |
2423 current found) | |
2424 (while children | |
2425 (setq current (car children) | |
2426 children (cdr children)) | |
2427 (let* ((button (widget-get current :button)) | |
2428 (value (widget-apply button :value-get))) | |
2429 (when value | |
2430 (setq found (widget-apply current :value-inline) | |
2431 children nil)))) | |
2432 found)) | |
2433 | |
2434 (defun widget-radio-value-set (widget value) | |
2435 ;; We can't just delete and recreate a radio widget, since children | |
2436 ;; can be added after the original creation and won't be recreated | |
2437 ;; by `:create'. | |
2438 (let ((children (widget-get widget :children)) | |
2439 current found) | |
2440 (while children | |
2441 (setq current (car children) | |
2442 children (cdr children)) | |
2443 (let* ((button (widget-get current :button)) | |
2444 (match (and (not found) | |
2445 (widget-apply current :match value)))) | |
2446 (widget-value-set button match) | |
2447 (if match | |
2448 (progn | |
2449 (widget-value-set current value) | |
2450 (widget-apply current :activate)) | |
2451 (widget-apply current :deactivate)) | |
2452 (setq found (or found match)))))) | |
2453 | |
2454 (defun widget-radio-validate (widget) | |
2455 ;; Valid if we have made a valid choice. | |
2456 (let ((children (widget-get widget :children)) | |
2457 current found button) | |
2458 (while (and children (not found)) | |
2459 (setq current (car children) | |
2460 children (cdr children) | |
2461 button (widget-get current :button) | |
2462 found (widget-apply button :value-get))) | |
2463 (if found | |
2464 (widget-apply current :validate) | |
2465 widget))) | |
2466 | |
2467 (defun widget-radio-action (widget child event) | |
2468 ;; Check if a radio button was pressed. | |
2469 (let ((children (widget-get widget :children)) | |
2470 (buttons (widget-get widget :buttons)) | |
2471 current) | |
2472 (when (memq child buttons) | |
2473 (while children | |
2474 (setq current (car children) | |
2475 children (cdr children)) | |
2476 (let* ((button (widget-get current :button))) | |
2477 (cond ((eq child button) | |
2478 (widget-value-set button t) | |
2479 (widget-apply current :activate)) | |
2480 ((widget-value button) | |
2481 (widget-value-set button nil) | |
2482 (widget-apply current :deactivate))))))) | |
2483 ;; Pass notification to parent. | |
2484 (widget-apply widget :notify child event)) | |
2485 | |
2486 ;;; The `insert-button' Widget. | |
2487 | |
2488 (define-widget 'insert-button 'push-button | |
2489 "An insert button for the `editable-list' widget." | |
2490 :tag "INS" | |
2491 :help-echo "Insert a new item into the list at this position." | |
2492 :action 'widget-insert-button-action) | |
2493 | |
2494 (defun widget-insert-button-action (widget &optional event) | |
2495 ;; Ask the parent to insert a new item. | |
2496 (widget-apply (widget-get widget :parent) | |
2497 :insert-before (widget-get widget :widget))) | |
2498 | |
2499 ;;; The `delete-button' Widget. | |
2500 | |
2501 (define-widget 'delete-button 'push-button | |
2502 "A delete button for the `editable-list' widget." | |
2503 :tag "DEL" | |
2504 :help-echo "Delete this item from the list." | |
2505 :action 'widget-delete-button-action) | |
2506 | |
2507 (defun widget-delete-button-action (widget &optional event) | |
2508 ;; Ask the parent to insert a new item. | |
2509 (widget-apply (widget-get widget :parent) | |
2510 :delete-at (widget-get widget :widget))) | |
2511 | |
2512 ;;; The `editable-list' Widget. | |
2513 | |
2514 (defcustom widget-editable-list-gui nil | |
2515 "If non nil, use GUI push-buttons in editable list when available." | |
2516 :type 'boolean | |
2517 :group 'widgets) | |
2518 | |
2519 (define-widget 'editable-list 'default | |
2520 "A variable list of widgets of the same type." | |
2521 :convert-widget 'widget-types-convert-widget | |
2522 :offset 12 | |
2523 :format "%v%i\n" | |
2524 :format-handler 'widget-editable-list-format-handler | |
2525 :entry-format "%i %d %v" | |
2526 :menu-tag "editable-list" | |
2527 :value-create 'widget-editable-list-value-create | |
2528 :value-delete 'widget-children-value-delete | |
2529 :value-get 'widget-editable-list-value-get | |
17799 | 2530 :validate 'widget-children-validate |
17334 | 2531 :match 'widget-editable-list-match |
2532 :match-inline 'widget-editable-list-match-inline | |
2533 :insert-before 'widget-editable-list-insert-before | |
2534 :delete-at 'widget-editable-list-delete-at) | |
2535 | |
2536 (defun widget-editable-list-format-handler (widget escape) | |
2537 ;; We recognize the insert button. | |
2538 (let ((widget-push-button-gui widget-editable-list-gui)) | |
2539 (cond ((eq escape ?i) | |
2540 (and (widget-get widget :indent) | |
2541 (insert-char ? (widget-get widget :indent))) | |
2542 (apply 'widget-create-child-and-convert | |
2543 widget 'insert-button | |
2544 (widget-get widget :append-button-args))) | |
2545 (t | |
2546 (widget-default-format-handler widget escape))))) | |
2547 | |
2548 (defun widget-editable-list-value-create (widget) | |
2549 ;; Insert all values | |
2550 (let* ((value (widget-get widget :value)) | |
2551 (type (nth 0 (widget-get widget :args))) | |
2552 (inlinep (widget-get type :inline)) | |
2553 children) | |
2554 (widget-put widget :value-pos (copy-marker (point))) | |
2555 (set-marker-insertion-type (widget-get widget :value-pos) t) | |
2556 (while value | |
2557 (let ((answer (widget-match-inline type value))) | |
2558 (if answer | |
2559 (setq children (cons (widget-editable-list-entry-create | |
2560 widget | |
2561 (if inlinep | |
2562 (car answer) | |
2563 (car (car answer))) | |
2564 t) | |
2565 children) | |
2566 value (cdr answer)) | |
2567 (setq value nil)))) | |
2568 (widget-put widget :children (nreverse children)))) | |
2569 | |
2570 (defun widget-editable-list-value-get (widget) | |
2571 ;; Get value of the child widget. | |
2572 (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) | |
2573 (widget-get widget :children)))) | |
2574 | |
2575 (defun widget-editable-list-match (widget value) | |
2576 ;; Value must be a list and all the members must match the type. | |
2577 (and (listp value) | |
2578 (null (cdr (widget-editable-list-match-inline widget value))))) | |
2579 | |
2580 (defun widget-editable-list-match-inline (widget value) | |
2581 (let ((type (nth 0 (widget-get widget :args))) | |
2582 (ok t) | |
2583 found) | |
2584 (while (and value ok) | |
2585 (let ((answer (widget-match-inline type value))) | |
2586 (if answer | |
2587 (setq found (append found (car answer)) | |
2588 value (cdr answer)) | |
2589 (setq ok nil)))) | |
2590 (cons found value))) | |
2591 | |
2592 (defun widget-editable-list-insert-before (widget before) | |
2593 ;; Insert a new child in the list of children. | |
2594 (save-excursion | |
2595 (let ((children (widget-get widget :children)) | |
2596 (inhibit-read-only t) | |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2597 before-change-functions |
17334 | 2598 after-change-functions) |
2599 (cond (before | |
2600 (goto-char (widget-get before :entry-from))) | |
2601 (t | |
2602 (goto-char (widget-get widget :value-pos)))) | |
2603 (let ((child (widget-editable-list-entry-create | |
2604 widget nil nil))) | |
2605 (when (< (widget-get child :entry-from) (widget-get widget :from)) | |
2606 (set-marker (widget-get widget :from) | |
2607 (widget-get child :entry-from))) | |
2608 (if (eq (car children) before) | |
2609 (widget-put widget :children (cons child children)) | |
2610 (while (not (eq (car (cdr children)) before)) | |
2611 (setq children (cdr children))) | |
2612 (setcdr children (cons child (cdr children))))))) | |
2613 (widget-setup) | |
18090 | 2614 (widget-apply widget :notify widget)) |
17334 | 2615 |
2616 (defun widget-editable-list-delete-at (widget child) | |
2617 ;; Delete child from list of children. | |
2618 (save-excursion | |
17535
4d7f2035303a
Use copy-sequence, not copy-list.
Richard M. Stallman <rms@gnu.org>
parents:
17415
diff
changeset
|
2619 (let ((buttons (copy-sequence (widget-get widget :buttons))) |
17334 | 2620 button |
2621 (inhibit-read-only t) | |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2622 before-change-functions |
17334 | 2623 after-change-functions) |
2624 (while buttons | |
2625 (setq button (car buttons) | |
2626 buttons (cdr buttons)) | |
2627 (when (eq (widget-get button :widget) child) | |
2628 (widget-put widget | |
2629 :buttons (delq button (widget-get widget :buttons))) | |
2630 (widget-delete button)))) | |
2631 (let ((entry-from (widget-get child :entry-from)) | |
2632 (entry-to (widget-get child :entry-to)) | |
2633 (inhibit-read-only t) | |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2634 before-change-functions |
17334 | 2635 after-change-functions) |
2636 (widget-delete child) | |
2637 (delete-region entry-from entry-to) | |
2638 (set-marker entry-from nil) | |
2639 (set-marker entry-to nil)) | |
2640 (widget-put widget :children (delq child (widget-get widget :children)))) | |
2641 (widget-setup) | |
2642 (widget-apply widget :notify widget)) | |
2643 | |
2644 (defun widget-editable-list-entry-create (widget value conv) | |
2645 ;; Create a new entry to the list. | |
2646 (let ((type (nth 0 (widget-get widget :args))) | |
2647 (widget-push-button-gui widget-editable-list-gui) | |
2648 child delete insert) | |
2649 (widget-specify-insert | |
2650 (save-excursion | |
2651 (and (widget-get widget :indent) | |
2652 (insert-char ? (widget-get widget :indent))) | |
2653 (insert (widget-get widget :entry-format))) | |
2654 ;; Parse % escapes in format. | |
2655 (while (re-search-forward "%\\(.\\)" nil t) | |
2656 (let ((escape (aref (match-string 1) 0))) | |
2657 (replace-match "" t t) | |
2658 (cond ((eq escape ?%) | |
2659 (insert "%")) | |
2660 ((eq escape ?i) | |
2661 (setq insert (apply 'widget-create-child-and-convert | |
2662 widget 'insert-button | |
2663 (widget-get widget :insert-button-args)))) | |
2664 ((eq escape ?d) | |
2665 (setq delete (apply 'widget-create-child-and-convert | |
2666 widget 'delete-button | |
2667 (widget-get widget :delete-button-args)))) | |
2668 ((eq escape ?v) | |
2669 (if conv | |
2670 (setq child (widget-create-child-value | |
2671 widget type value)) | |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2672 (setq child (widget-create-child-value |
22496
cad4818f198f
(widget-default-get): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
22468
diff
changeset
|
2673 widget type |
cad4818f198f
(widget-default-get): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
22468
diff
changeset
|
2674 (widget-apply type :value-to-external |
cad4818f198f
(widget-default-get): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
22468
diff
changeset
|
2675 (widget-default-get type)))))) |
17334 | 2676 (t |
2677 (error "Unknown escape `%c'" escape))))) | |
2678 (widget-put widget | |
2679 :buttons (cons delete | |
2680 (cons insert | |
2681 (widget-get widget :buttons)))) | |
2682 (let ((entry-from (copy-marker (point-min))) | |
2683 (entry-to (copy-marker (point-max)))) | |
2684 (set-marker-insertion-type entry-from t) | |
2685 (set-marker-insertion-type entry-to nil) | |
2686 (widget-put child :entry-from entry-from) | |
2687 (widget-put child :entry-to entry-to))) | |
2688 (widget-put insert :widget child) | |
2689 (widget-put delete :widget child) | |
2690 child)) | |
2691 | |
2692 ;;; The `group' Widget. | |
2693 | |
2694 (define-widget 'group 'default | |
2695 "A widget which group other widgets inside." | |
2696 :convert-widget 'widget-types-convert-widget | |
2697 :format "%v" | |
2698 :value-create 'widget-group-value-create | |
2699 :value-delete 'widget-children-value-delete | |
2700 :value-get 'widget-editable-list-value-get | |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2701 :default-get 'widget-group-default-get |
17799 | 2702 :validate 'widget-children-validate |
17334 | 2703 :match 'widget-group-match |
2704 :match-inline 'widget-group-match-inline) | |
2705 | |
2706 (defun widget-group-value-create (widget) | |
2707 ;; Create each component. | |
2708 (let ((args (widget-get widget :args)) | |
2709 (value (widget-get widget :value)) | |
2710 arg answer children) | |
2711 (while args | |
2712 (setq arg (car args) | |
2713 args (cdr args) | |
2714 answer (widget-match-inline arg value) | |
2715 value (cdr answer)) | |
2716 (and (eq (preceding-char) ?\n) | |
2717 (widget-get widget :indent) | |
2718 (insert-char ? (widget-get widget :indent))) | |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2719 (push (cond ((null answer) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2720 (widget-create-child widget arg)) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2721 ((widget-get arg :inline) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2722 (widget-create-child-value widget arg (car answer))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2723 (t |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2724 (widget-create-child-value widget arg (car (car answer))))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2725 children)) |
17334 | 2726 (widget-put widget :children (nreverse children)))) |
2727 | |
21428
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2728 (defun widget-group-default-get (widget) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2729 ;; Get the default of the components. |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2730 (mapcar 'widget-default-get (widget-get widget :args))) |
28157e58238a
(default, widget-default-default-get): Define it.
Richard M. Stallman <rms@gnu.org>
parents:
21338
diff
changeset
|
2731 |
17334 | 2732 (defun widget-group-match (widget values) |
2733 ;; Match if the components match. | |
2734 (and (listp values) | |
2735 (let ((match (widget-group-match-inline widget values))) | |
2736 (and match (null (cdr match)))))) | |
2737 | |
2738 (defun widget-group-match-inline (widget vals) | |
2739 ;; Match if the components match. | |
2740 (let ((args (widget-get widget :args)) | |
2741 argument answer found) | |
2742 (while args | |
2743 (setq argument (car args) | |
2744 args (cdr args) | |
2745 answer (widget-match-inline argument vals)) | |
2746 (if answer | |
2747 (setq vals (cdr answer) | |
2748 found (append found (car answer))) | |
2749 (setq vals nil | |
2750 args nil))) | |
2751 (if answer | |
2752 (cons found vals) | |
2753 nil))) | |
2754 | |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2755 ;;; The `visibility' Widget. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2756 |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2757 (define-widget 'visibility 'item |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2758 "An indicator and manipulator for hidden items." |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2759 :format "%[%v%]" |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2760 :button-prefix "" |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2761 :button-suffix "" |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2762 :on "Hide" |
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2763 :off "Show" |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2764 :value-create 'widget-visibility-value-create |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2765 :action 'widget-toggle-action |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2766 :match (lambda (widget value) t)) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2767 |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2768 (defun widget-visibility-value-create (widget) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2769 ;; Insert text representing the `on' and `off' states. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2770 (let ((on (widget-get widget :on)) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2771 (off (widget-get widget :off))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2772 (if on |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2773 (setq on (concat widget-push-button-prefix |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2774 on |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2775 widget-push-button-suffix)) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2776 (setq on "")) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2777 (if off |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2778 (setq off (concat widget-push-button-prefix |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2779 off |
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2780 widget-push-button-suffix)) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2781 (setq off "")) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2782 (if (widget-value widget) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2783 (widget-glyph-insert widget on "down" "down-pushed") |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2784 (widget-glyph-insert widget off "right" "right-pushed")))) |
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2785 |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2786 ;;; The `documentation-link' Widget. |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2787 ;; |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2788 ;; This is a helper widget for `documentation-string'. |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2789 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2790 (define-widget 'documentation-link 'link |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2791 "Link type used in documentation strings." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2792 :tab-order -1 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2793 :help-echo 'widget-documentation-link-echo-help |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2794 :action 'widget-documentation-link-action) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2795 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2796 (defun widget-documentation-link-echo-help (widget) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2797 "Tell what this link will describe." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2798 (concat "Describe the `" (widget-get widget :value) "' symbol.")) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2799 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2800 (defun widget-documentation-link-action (widget &optional event) |
18366 | 2801 "Display documentation for WIDGET's value. Ignore optional argument EVENT." |
18365
ceb9388fe67f
(widget-documentation-link-action):
Richard M. Stallman <rms@gnu.org>
parents:
18364
diff
changeset
|
2802 (let* ((string (widget-get widget :value)) |
ceb9388fe67f
(widget-documentation-link-action):
Richard M. Stallman <rms@gnu.org>
parents:
18364
diff
changeset
|
2803 (symbol (intern string))) |
ceb9388fe67f
(widget-documentation-link-action):
Richard M. Stallman <rms@gnu.org>
parents:
18364
diff
changeset
|
2804 (if (and (fboundp symbol) (boundp symbol)) |
18366 | 2805 ;; If there are two doc strings, give the user a way to pick one. |
18365
ceb9388fe67f
(widget-documentation-link-action):
Richard M. Stallman <rms@gnu.org>
parents:
18364
diff
changeset
|
2806 (apropos (concat "\\`" (regexp-quote string) "\\'")) |
ceb9388fe67f
(widget-documentation-link-action):
Richard M. Stallman <rms@gnu.org>
parents:
18364
diff
changeset
|
2807 (if (fboundp symbol) |
ceb9388fe67f
(widget-documentation-link-action):
Richard M. Stallman <rms@gnu.org>
parents:
18364
diff
changeset
|
2808 (describe-function symbol) |
ceb9388fe67f
(widget-documentation-link-action):
Richard M. Stallman <rms@gnu.org>
parents:
18364
diff
changeset
|
2809 (describe-variable symbol))))) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2810 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2811 (defcustom widget-documentation-links t |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2812 "Add hyperlinks to documentation strings when non-nil." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2813 :type 'boolean |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2814 :group 'widget-documentation) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2815 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2816 (defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'" |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2817 "Regexp for matching potential links in documentation strings. |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2818 The first group should be the link itself." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2819 :type 'regexp |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2820 :group 'widget-documentation) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2821 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2822 (defcustom widget-documentation-link-p 'intern-soft |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2823 "Predicate used to test if a string is useful as a link. |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2824 The value should be a function. The function will be called one |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2825 argument, a string, and should return non-nil if there should be a |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2826 link for that string." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2827 :type 'function |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2828 :options '(widget-documentation-link-p) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2829 :group 'widget-documentation) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2830 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2831 (defcustom widget-documentation-link-type 'documentation-link |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2832 "Widget type used for links in documentation strings." |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2833 :type 'symbol |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2834 :group 'widget-documentation) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2835 |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2836 (defun widget-documentation-link-add (widget from to) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2837 (widget-specify-doc widget from to) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2838 (when widget-documentation-links |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2839 (let ((regexp widget-documentation-link-regexp) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2840 (predicate widget-documentation-link-p) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2841 (type widget-documentation-link-type) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2842 (buttons (widget-get widget :buttons))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2843 (save-excursion |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2844 (goto-char from) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2845 (while (re-search-forward regexp to t) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2846 (let ((name (match-string 1)) |
18336
325190603227
Synched with 1.9924.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18258
diff
changeset
|
2847 (begin (match-beginning 1)) |
325190603227
Synched with 1.9924.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18258
diff
changeset
|
2848 (end (match-end 1))) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2849 (when (funcall predicate name) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2850 (push (widget-convert-button type begin end :value name) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2851 buttons))))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2852 (widget-put widget :buttons buttons))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2853 (let ((indent (widget-get widget :indent))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2854 (when (and indent (not (zerop indent))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2855 (save-excursion |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2856 (save-restriction |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2857 (narrow-to-region from to) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2858 (goto-char (point-min)) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2859 (while (search-forward "\n" nil t) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2860 (insert-char ?\ indent))))))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2861 |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2862 ;;; The `documentation-string' Widget. |
17334 | 2863 |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2864 (define-widget 'documentation-string 'item |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2865 "A documentation string." |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2866 :format "%v" |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2867 :action 'widget-documentation-string-action |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2868 :value-delete 'widget-children-value-delete |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2869 :value-create 'widget-documentation-string-value-create) |
17334 | 2870 |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2871 (defun widget-documentation-string-value-create (widget) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2872 ;; Insert documentation string. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2873 (let ((doc (widget-value widget)) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2874 (indent (widget-get widget :indent)) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
2875 (shown (widget-get (widget-get widget :parent) :documentation-shown)) |
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
2876 (start (point))) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2877 (if (string-match "\n" doc) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2878 (let ((before (substring doc 0 (match-beginning 0))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2879 (after (substring doc (match-beginning 0))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2880 buttons) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2881 (insert before " ") |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2882 (widget-documentation-link-add widget start (point)) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2883 (push (widget-create-child-and-convert |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2884 widget 'visibility |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2885 :help-echo "Show or hide rest of the documentation." |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
2886 :off "More" |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2887 :action 'widget-parent-action |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2888 shown) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2889 buttons) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2890 (when shown |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
2891 (setq start (point)) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2892 (when (and indent (not (zerop indent))) |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2893 (insert-char ?\ indent)) |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
2894 (insert after) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2895 (widget-documentation-link-add widget start (point))) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2896 (widget-put widget :buttons buttons)) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
2897 (insert doc) |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
2898 (widget-documentation-link-add widget start (point)))) |
18067
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2899 (insert "\n")) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2900 |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2901 (defun widget-documentation-string-action (widget &rest ignore) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2902 ;; Toggle documentation. |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2903 (let ((parent (widget-get widget :parent))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2904 (widget-put parent :documentation-shown |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2905 (not (widget-get parent :documentation-shown)))) |
0e2aa3b58e16
Synched with version 1.9901.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18056
diff
changeset
|
2906 ;; Redraw. |
17334 | 2907 (widget-value-set widget (widget-value widget))) |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
2908 |
17334 | 2909 ;;; The Sexp Widgets. |
2910 | |
2911 (define-widget 'const 'item | |
2912 "An immutable sexp." | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2913 :prompt-value 'widget-const-prompt-value |
17334 | 2914 :format "%t\n%d") |
2915 | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2916 (defun widget-const-prompt-value (widget prompt value unbound) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2917 ;; Return the value of the const. |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2918 (widget-value widget)) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2919 |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2920 (define-widget 'function-item 'const |
17334 | 2921 "An immutable function name." |
2922 :format "%v\n%h" | |
2923 :documentation-property (lambda (symbol) | |
2924 (condition-case nil | |
2925 (documentation symbol t) | |
2926 (error nil)))) | |
2927 | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2928 (define-widget 'variable-item 'const |
17334 | 2929 "An immutable variable name." |
2930 :format "%v\n%h" | |
2931 :documentation-property 'variable-documentation) | |
2932 | |
22421
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2933 (define-widget 'other 'sexp |
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2934 "Matches any value, but doesn't let the user edit the value. |
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2935 This is useful as last item in a `choice' widget. |
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2936 You should use this widget type with a default value, |
22468 | 2937 as in (other DEFAULT) or (other :tag \"NAME\" DEFAULT). |
22421
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2938 If the user selects this alternative, that specifies DEFAULT |
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2939 as the value." |
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2940 :tag "Other" |
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2941 :format "%t%n" |
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2942 :value 'other) |
b23a720f3b4f
(other): New widget type.
Richard M. Stallman <rms@gnu.org>
parents:
22004
diff
changeset
|
2943 |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2944 (defvar widget-string-prompt-value-history nil |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2945 "History of input to `widget-string-prompt-value'.") |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2946 |
17799 | 2947 (define-widget 'string 'editable-field |
2948 "A string" | |
2949 :tag "String" | |
2950 :format "%{%t%}: %v" | |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
2951 :complete-function 'ispell-complete-word |
17799 | 2952 :prompt-history 'widget-string-prompt-value-history) |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2953 |
17334 | 2954 (define-widget 'regexp 'string |
2955 "A regular expression." | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2956 :match 'widget-regexp-match |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2957 :validate 'widget-regexp-validate |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
2958 ;; Doesn't work well with terminating newline. |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
2959 ;; :value-face 'widget-single-line-field-face |
17334 | 2960 :tag "Regexp") |
2961 | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2962 (defun widget-regexp-match (widget value) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2963 ;; Match valid regexps. |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2964 (and (stringp value) |
17799 | 2965 (condition-case nil |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2966 (prog1 t |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2967 (string-match value "")) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2968 (error nil)))) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2969 |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2970 (defun widget-regexp-validate (widget) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2971 "Check that the value of WIDGET is a valid regexp." |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2972 (let ((val (widget-value widget))) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2973 (condition-case data |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2974 (prog1 nil |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2975 (string-match val "")) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2976 (error (widget-put widget :error (error-message-string data)) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2977 widget)))) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2978 |
17334 | 2979 (define-widget 'file 'string |
2980 "A file widget. | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
2981 It will read a file name from the minibuffer when invoked." |
18372
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2982 :complete-function 'widget-file-complete |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
2983 :prompt-value 'widget-file-prompt-value |
17799 | 2984 :format "%{%t%}: %v" |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
2985 ;; Doesn't work well with terminating newline. |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
2986 ;; :value-face 'widget-single-line-field-face |
18372
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2987 :tag "File") |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2988 |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2989 (defun widget-file-complete () |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2990 "Perform completion on file name preceding point." |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2991 (interactive) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2992 (let* ((end (point)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2993 (beg (save-excursion |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2994 (skip-chars-backward "^ ") |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2995 (point))) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2996 (pattern (buffer-substring beg end)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2997 (name-part (file-name-nondirectory pattern)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2998 (directory (file-name-directory pattern)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
2999 (completion (file-name-completion name-part directory))) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3000 (cond ((eq completion t)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3001 ((null completion) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3002 (message "Can't find completion for \"%s\"" pattern) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3003 (ding)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3004 ((not (string= name-part completion)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3005 (delete-region beg end) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3006 (insert (expand-file-name completion directory))) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3007 (t |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3008 (message "Making completion list...") |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3009 (let ((list (file-name-all-completions name-part directory))) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3010 (setq list (sort list 'string<)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3011 (with-output-to-temp-buffer "*Completions*" |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3012 (display-completion-list list))) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3013 (message "Making completion list...%s" "done"))))) |
17334 | 3014 |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3015 (defun widget-file-prompt-value (widget prompt value unbound) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3016 ;; Read file from minibuffer. |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3017 (abbreviate-file-name |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3018 (if unbound |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3019 (read-file-name prompt) |
17799 | 3020 (let ((prompt2 (format "%s (default %s) " prompt value)) |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3021 (dir (file-name-directory value)) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3022 (file (file-name-nondirectory value)) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3023 (must-match (widget-get widget :must-match))) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3024 (read-file-name prompt2 dir nil must-match file))))) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3025 |
18372
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3026 ;;;(defun widget-file-action (widget &optional event) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3027 ;;; ;; Read a file name from the minibuffer. |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3028 ;;; (let* ((value (widget-value widget)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3029 ;;; (dir (file-name-directory value)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3030 ;;; (file (file-name-nondirectory value)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3031 ;;; (menu-tag (widget-apply widget :menu-tag-get)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3032 ;;; (must-match (widget-get widget :must-match)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3033 ;;; (answer (read-file-name (concat menu-tag ": (default `" value "') ") |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3034 ;;; dir nil must-match file))) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3035 ;;; (widget-value-set widget (abbreviate-file-name answer)) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3036 ;;; (widget-setup) |
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3037 ;;; (widget-apply widget :notify widget event))) |
17334 | 3038 |
3039 (define-widget 'directory 'file | |
3040 "A directory widget. | |
18033
bccd356a3b7c
Synched with version 1.9900.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17799
diff
changeset
|
3041 It will read a directory name from the minibuffer when invoked." |
17334 | 3042 :tag "Directory") |
3043 | |
17799 | 3044 (defvar widget-symbol-prompt-value-history nil |
3045 "History of input to `widget-symbol-prompt-value'.") | |
3046 | |
3047 (define-widget 'symbol 'editable-field | |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
3048 "A Lisp symbol." |
17334 | 3049 :value nil |
3050 :tag "Symbol" | |
17799 | 3051 :format "%{%t%}: %v" |
17334 | 3052 :match (lambda (widget value) (symbolp value)) |
18372
5b5261ce8db9
(widget-file-complete): New function.
Richard M. Stallman <rms@gnu.org>
parents:
18369
diff
changeset
|
3053 :complete-function 'lisp-complete-symbol |
17799 | 3054 :prompt-internal 'widget-symbol-prompt-internal |
3055 :prompt-match 'symbolp | |
3056 :prompt-history 'widget-symbol-prompt-value-history | |
17334 | 3057 :value-to-internal (lambda (widget value) |
3058 (if (symbolp value) | |
3059 (symbol-name value) | |
3060 value)) | |
3061 :value-to-external (lambda (widget value) | |
3062 (if (stringp value) | |
3063 (intern value) | |
3064 value))) | |
3065 | |
17799 | 3066 (defun widget-symbol-prompt-internal (widget prompt initial history) |
3067 ;; Read file from minibuffer. | |
3068 (let ((answer (completing-read prompt obarray | |
3069 (widget-get widget :prompt-match) | |
3070 nil initial history))) | |
3071 (if (and (stringp answer) | |
3072 (not (zerop (length answer)))) | |
3073 answer | |
3074 (error "No value")))) | |
3075 | |
3076 (defvar widget-function-prompt-value-history nil | |
3077 "History of input to `widget-function-prompt-value'.") | |
3078 | |
17334 | 3079 (define-widget 'function 'sexp |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
3080 "A Lisp function." |
18138
fa4eb2f6b05a
Synached with 1.9908.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18090
diff
changeset
|
3081 :complete-function 'lisp-complete-symbol |
17799 | 3082 :prompt-value 'widget-field-prompt-value |
3083 :prompt-internal 'widget-symbol-prompt-internal | |
3084 :prompt-match 'fboundp | |
3085 :prompt-history 'widget-function-prompt-value-history | |
3086 :action 'widget-field-action | |
17334 | 3087 :tag "Function") |
3088 | |
17799 | 3089 (defvar widget-variable-prompt-value-history nil |
3090 "History of input to `widget-variable-prompt-value'.") | |
3091 | |
17334 | 3092 (define-widget 'variable 'symbol |
3093 ;; Should complete on variables. | |
22004
79a3c4eba19f
(widgets: sexp, variable, list, vector): Doc fixes.
Richard M. Stallman <rms@gnu.org>
parents:
21428
diff
changeset
|
3094 "A Lisp variable." |
17799 | 3095 :prompt-match 'boundp |
3096 :prompt-history 'widget-variable-prompt-value-history | |
17334 | 3097 :tag "Variable") |
3098 | |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3099 (defvar widget-coding-system-prompt-value-history nil |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3100 "History of input to `widget-coding-system-prompt-value'.") |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
3101 |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3102 (define-widget 'coding-system 'symbol |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3103 "A MULE coding-system." |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3104 :format "%{%t%}: %v" |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3105 :tag "Coding system" |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3106 :prompt-history 'widget-coding-system-prompt-value-history |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3107 :prompt-value 'widget-coding-system-prompt-value |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3108 :action 'widget-coding-system-action) |
18244
909a0f9169b8
Synched with 1.9914.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18138
diff
changeset
|
3109 |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3110 (defun widget-coding-system-prompt-value (widget prompt value unbound) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3111 ;; Read coding-system from minibuffer. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3112 (intern |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3113 (completing-read (format "%s (default %s) " prompt value) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3114 (mapcar (function |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3115 (lambda (sym) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3116 (list (symbol-name sym)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3117 )) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3118 (coding-system-list))))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3119 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3120 (defun widget-coding-system-action (widget &optional event) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3121 ;; Read a file name from the minibuffer. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3122 (let ((answer |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3123 (widget-coding-system-prompt-value |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3124 widget |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3125 (widget-apply widget :menu-tag-get) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3126 (widget-value widget) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3127 t))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3128 (widget-value-set widget answer) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3129 (widget-apply widget :notify widget event) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3130 (widget-setup))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3131 |
17799 | 3132 (define-widget 'sexp 'editable-field |
22004
79a3c4eba19f
(widgets: sexp, variable, list, vector): Doc fixes.
Richard M. Stallman <rms@gnu.org>
parents:
21428
diff
changeset
|
3133 "An arbitrary Lisp expression." |
17334 | 3134 :tag "Lisp expression" |
17799 | 3135 :format "%{%t%}: %v" |
17334 | 3136 :value nil |
3137 :validate 'widget-sexp-validate | |
3138 :match (lambda (widget value) t) | |
3139 :value-to-internal 'widget-sexp-value-to-internal | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3140 :value-to-external (lambda (widget value) (read value)) |
17799 | 3141 :prompt-history 'widget-sexp-prompt-value-history |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3142 :prompt-value 'widget-sexp-prompt-value) |
17334 | 3143 |
3144 (defun widget-sexp-value-to-internal (widget value) | |
3145 ;; Use pp for printer representation. | |
18055
9e0c7dffc231
(widget-sexp-value-to-internal):
Richard M. Stallman <rms@gnu.org>
parents:
18033
diff
changeset
|
3146 (let ((pp (if (symbolp value) |
9e0c7dffc231
(widget-sexp-value-to-internal):
Richard M. Stallman <rms@gnu.org>
parents:
18033
diff
changeset
|
3147 (prin1-to-string value) |
9e0c7dffc231
(widget-sexp-value-to-internal):
Richard M. Stallman <rms@gnu.org>
parents:
18033
diff
changeset
|
3148 (pp-to-string value)))) |
17334 | 3149 (while (string-match "\n\\'" pp) |
3150 (setq pp (substring pp 0 -1))) | |
3151 (if (or (string-match "\n\\'" pp) | |
3152 (> (length pp) 40)) | |
3153 (concat "\n" pp) | |
3154 pp))) | |
3155 | |
3156 (defun widget-sexp-validate (widget) | |
3157 ;; Valid if we can read the string and there is no junk left after it. | |
3158 (save-excursion | |
3159 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) | |
3160 (erase-buffer) | |
3161 (insert (widget-apply widget :value-get)) | |
3162 (goto-char (point-min)) | |
3163 (condition-case data | |
3164 (let ((value (read buffer))) | |
3165 (if (eobp) | |
3166 (if (widget-apply widget :match value) | |
3167 nil | |
3168 (widget-put widget :error (widget-get widget :type-error)) | |
3169 widget) | |
3170 (widget-put widget | |
3171 :error (format "Junk at end of expression: %s" | |
3172 (buffer-substring (point) | |
3173 (point-max)))) | |
3174 widget)) | |
3175 (error (widget-put widget :error (error-message-string data)) | |
3176 widget))))) | |
3177 | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3178 (defvar widget-sexp-prompt-value-history nil |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3179 "History of input to `widget-sexp-prompt-value'.") |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3180 |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3181 (defun widget-sexp-prompt-value (widget prompt value unbound) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3182 ;; Read an arbitrary sexp. |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3183 (let ((found (read-string prompt |
17799 | 3184 (if unbound nil (cons (prin1-to-string value) 0)) |
3185 (widget-get widget :prompt-history)))) | |
3186 (save-excursion | |
3187 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) | |
3188 (erase-buffer) | |
3189 (insert found) | |
3190 (goto-char (point-min)) | |
3191 (let ((answer (read buffer))) | |
3192 (unless (eobp) | |
3193 (error "Junk at end of expression: %s" | |
3194 (buffer-substring (point) (point-max)))) | |
3195 answer))))) | |
3196 | |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3197 (define-widget 'restricted-sexp 'sexp |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3198 "A Lisp expression restricted to values that match. |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3199 To use this type, you must define :match or :match-alternatives." |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3200 :type-error "The specified value is not valid" |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3201 :match 'widget-restricted-sexp-match |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3202 :value-to-internal (lambda (widget value) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3203 (if (widget-apply widget :match value) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3204 (prin1-to-string value) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3205 value))) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3206 |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3207 (defun widget-restricted-sexp-match (widget value) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3208 (let ((alternatives (widget-get widget :match-alternatives)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3209 matched) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3210 (while (and alternatives (not matched)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3211 (if (cond ((functionp (car alternatives)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3212 (funcall (car alternatives) value)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3213 ((and (consp (car alternatives)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3214 (eq (car (car alternatives)) 'quote)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3215 (eq value (nth 1 (car alternatives))))) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3216 (setq matched t)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3217 (setq alternatives (cdr alternatives))) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3218 matched)) |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3219 |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3220 (define-widget 'integer 'restricted-sexp |
17334 | 3221 "An integer." |
3222 :tag "Integer" | |
3223 :value 0 | |
3224 :type-error "This field should contain an integer" | |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3225 :match-alternatives '(integerp)) |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3226 |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3227 (define-widget 'number 'restricted-sexp |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3228 "A floating point number." |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3229 :tag "Number" |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3230 :value 0.0 |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3231 :type-error "This field should contain a number" |
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3232 :match-alternatives '(numberp)) |
17334 | 3233 |
17799 | 3234 (define-widget 'character 'editable-field |
18438
947c1b6ea8de
(widget-menu-minibuffer-flag): New variable.
Richard M. Stallman <rms@gnu.org>
parents:
18429
diff
changeset
|
3235 "A character." |
17334 | 3236 :tag "Character" |
3237 :value 0 | |
3238 :size 1 | |
3239 :format "%{%t%}: %v\n" | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3240 :valid-regexp "\\`.\\'" |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3241 :error "This field should contain a single character" |
17334 | 3242 :value-to-internal (lambda (widget value) |
17799 | 3243 (if (stringp value) |
3244 value | |
3245 (char-to-string value))) | |
17334 | 3246 :value-to-external (lambda (widget value) |
3247 (if (stringp value) | |
3248 (aref value 0) | |
3249 value)) | |
17799 | 3250 :match (lambda (widget value) |
3251 (if (fboundp 'characterp) | |
3252 (characterp value) | |
3253 (integerp value)))) | |
17334 | 3254 |
3255 (define-widget 'list 'group | |
22004
79a3c4eba19f
(widgets: sexp, variable, list, vector): Doc fixes.
Richard M. Stallman <rms@gnu.org>
parents:
21428
diff
changeset
|
3256 "A Lisp list." |
17334 | 3257 :tag "List" |
3258 :format "%{%t%}:\n%v") | |
3259 | |
3260 (define-widget 'vector 'group | |
22004
79a3c4eba19f
(widgets: sexp, variable, list, vector): Doc fixes.
Richard M. Stallman <rms@gnu.org>
parents:
21428
diff
changeset
|
3261 "A Lisp vector." |
17334 | 3262 :tag "Vector" |
3263 :format "%{%t%}:\n%v" | |
3264 :match 'widget-vector-match | |
3265 :value-to-internal (lambda (widget value) (append value nil)) | |
3266 :value-to-external (lambda (widget value) (apply 'vector value))) | |
3267 | |
3268 (defun widget-vector-match (widget value) | |
3269 (and (vectorp value) | |
3270 (widget-group-match widget | |
17415 | 3271 (widget-apply widget :value-to-internal value)))) |
17334 | 3272 |
3273 (define-widget 'cons 'group | |
3274 "A cons-cell." | |
3275 :tag "Cons-cell" | |
3276 :format "%{%t%}:\n%v" | |
3277 :match 'widget-cons-match | |
3278 :value-to-internal (lambda (widget value) | |
3279 (list (car value) (cdr value))) | |
3280 :value-to-external (lambda (widget value) | |
3281 (cons (nth 0 value) (nth 1 value)))) | |
3282 | |
3283 (defun widget-cons-match (widget value) | |
3284 (and (consp value) | |
3285 (widget-group-match widget | |
3286 (widget-apply widget :value-to-internal value)))) | |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3287 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3288 ;;; The `plist' Widget. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3289 ;; |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3290 ;; Property lists. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3291 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3292 (define-widget 'plist 'list |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3293 "A property list." |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3294 :key-type '(symbol :tag "Key") |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3295 :value-type '(sexp :tag "Value") |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3296 :convert-widget 'widget-plist-convert-widget |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3297 :tag "Plist") |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3298 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3299 (defvar widget-plist-value-type) ;Dynamic variable |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3300 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3301 (defun widget-plist-convert-widget (widget) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3302 ;; Handle `:options'. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3303 (let* ((options (widget-get widget :options)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3304 (key-type (widget-get widget :key-type)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3305 (widget-plist-value-type (widget-get widget :value-type)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3306 (other `(editable-list :inline t |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3307 (group :inline t |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3308 ,key-type |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3309 ,widget-plist-value-type))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3310 (args (if options |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3311 (list `(checklist :inline t |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3312 :greedy t |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3313 ,@(mapcar 'widget-plist-convert-option |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3314 options)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3315 other) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3316 (list other)))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3317 (widget-put widget :args args) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3318 widget)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3319 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3320 (defun widget-plist-convert-option (option) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3321 ;; Convert a single plist option. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3322 (let (key-type value-type) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3323 (if (listp option) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3324 (let ((key (nth 0 option))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3325 (setq value-type (nth 1 option)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3326 (if (listp key) |
24134
9fd3f3cc78c1
(widget-alist-convert-option): Delete spurious comma.
Richard M. Stallman <rms@gnu.org>
parents:
24124
diff
changeset
|
3327 (setq key-type key) |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3328 (setq key-type `(const ,key)))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3329 (setq key-type `(const ,option) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3330 value-type widget-plist-value-type)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3331 `(group :format "Key: %v" :inline t ,key-type ,value-type))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3332 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3333 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3334 ;;; The `alist' Widget. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3335 ;; |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3336 ;; Association lists. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3337 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3338 (define-widget 'alist 'list |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3339 "An association list." |
24124
21b9595acf22
(alist): Use sexp as default key-type.
Richard M. Stallman <rms@gnu.org>
parents:
24114
diff
changeset
|
3340 :key-type '(sexp :tag "Key") |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3341 :value-type '(sexp :tag "Value") |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3342 :convert-widget 'widget-alist-convert-widget |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3343 :tag "Alist") |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3344 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3345 (defvar widget-alist-value-type) ;Dynamic variable |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3346 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3347 (defun widget-alist-convert-widget (widget) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3348 ;; Handle `:options'. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3349 (let* ((options (widget-get widget :options)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3350 (key-type (widget-get widget :key-type)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3351 (widget-alist-value-type (widget-get widget :value-type)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3352 (other `(editable-list :inline t |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3353 (cons :format "%v" |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3354 ,key-type |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3355 ,widget-alist-value-type))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3356 (args (if options |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3357 (list `(checklist :inline t |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3358 :greedy t |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3359 ,@(mapcar 'widget-alist-convert-option |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3360 options)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3361 other) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3362 (list other)))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3363 (widget-put widget :args args) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3364 widget)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3365 |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3366 (defun widget-alist-convert-option (option) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3367 ;; Convert a single alist option. |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3368 (let (key-type value-type) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3369 (if (listp option) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3370 (let ((key (nth 0 option))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3371 (setq value-type (nth 1 option)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3372 (if (listp key) |
24134
9fd3f3cc78c1
(widget-alist-convert-option): Delete spurious comma.
Richard M. Stallman <rms@gnu.org>
parents:
24124
diff
changeset
|
3373 (setq key-type key) |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3374 (setq key-type `(const ,key)))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3375 (setq key-type `(const ,option) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3376 value-type widget-alist-value-type)) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3377 `(cons :format "Key: %v" ,key-type ,value-type))) |
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3378 |
17334 | 3379 (define-widget 'choice 'menu-choice |
3380 "A union of several sexp types." | |
3381 :tag "Choice" | |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
3382 :format "%{%t%}: %[Value Menu%] %v" |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
3383 :button-prefix 'widget-push-button-prefix |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
3384 :button-suffix 'widget-push-button-suffix |
17799 | 3385 :prompt-value 'widget-choice-prompt-value) |
3386 | |
3387 (defun widget-choice-prompt-value (widget prompt value unbound) | |
3388 "Make a choice." | |
3389 (let ((args (widget-get widget :args)) | |
3390 (completion-ignore-case (widget-get widget :case-fold)) | |
3391 current choices old) | |
3392 ;; Find the first arg that match VALUE. | |
3393 (let ((look args)) | |
3394 (while look | |
3395 (if (widget-apply (car look) :match value) | |
3396 (setq old (car look) | |
3397 look nil) | |
3398 (setq look (cdr look))))) | |
3399 ;; Find new choice. | |
3400 (setq current | |
3401 (cond ((= (length args) 0) | |
3402 nil) | |
3403 ((= (length args) 1) | |
3404 (nth 0 args)) | |
3405 ((and (= (length args) 2) | |
3406 (memq old args)) | |
3407 (if (eq old (nth 0 args)) | |
3408 (nth 1 args) | |
3409 (nth 0 args))) | |
3410 (t | |
3411 (while args | |
3412 (setq current (car args) | |
3413 args (cdr args)) | |
3414 (setq choices | |
3415 (cons (cons (widget-apply current :menu-tag-get) | |
3416 current) | |
3417 choices))) | |
3418 (let ((val (completing-read prompt choices nil t))) | |
3419 (if (stringp val) | |
3420 (let ((try (try-completion val choices))) | |
3421 (when (stringp try) | |
3422 (setq val try)) | |
3423 (cdr (assoc val choices))) | |
3424 nil))))) | |
3425 (if current | |
3426 (widget-prompt-value current prompt nil t) | |
3427 value))) | |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3428 |
17334 | 3429 (define-widget 'radio 'radio-button-choice |
3430 "A union of several sexp types." | |
3431 :tag "Choice" | |
17799 | 3432 :format "%{%t%}:\n%v" |
3433 :prompt-value 'widget-choice-prompt-value) | |
17334 | 3434 |
3435 (define-widget 'repeat 'editable-list | |
3436 "A variable length homogeneous list." | |
3437 :tag "Repeat" | |
3438 :format "%{%t%}:\n%v%i\n") | |
3439 | |
3440 (define-widget 'set 'checklist | |
3441 "A list of members from a fixed set." | |
3442 :tag "Set" | |
3443 :format "%{%t%}:\n%v") | |
3444 | |
3445 (define-widget 'boolean 'toggle | |
3446 "To be nil or non-nil, that is the question." | |
3447 :tag "Boolean" | |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3448 :prompt-value 'widget-boolean-prompt-value |
18258
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
3449 :button-prefix 'widget-push-button-prefix |
e83bc8150072
Synched with 1.9920.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18244
diff
changeset
|
3450 :button-suffix 'widget-push-button-suffix |
18361
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
3451 :format "%{%t%}: %[Toggle%] %v\n" |
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
3452 :on "on (non-nil)" |
eecbc06aed1c
(boolean): Capitalize "toggle".
Richard M. Stallman <rms@gnu.org>
parents:
18338
diff
changeset
|
3453 :off "off (nil)") |
17334 | 3454 |
17550
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3455 (defun widget-boolean-prompt-value (widget prompt value unbound) |
d6545cfb6c5a
Synched with custom 1.90.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
17536
diff
changeset
|
3456 ;; Toggle a boolean. |
17799 | 3457 (y-or-n-p prompt)) |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3458 |
17334 | 3459 ;;; The `color' Widget. |
3460 | |
18600
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3461 (define-widget 'color 'editable-field |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3462 "Choose a color name (with sample)." |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3463 :format "%t: %v (%{sample%})\n" |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3464 :size 10 |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3465 :tag "Color" |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3466 :value "black" |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3467 :complete 'widget-color-complete |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3468 :sample-face-get 'widget-color-sample-face-get |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3469 :notify 'widget-color-notify |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3470 :action 'widget-color-action) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3471 |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3472 (defun widget-color-complete (widget) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3473 "Complete the color in WIDGET." |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3474 (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3475 (point))) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3476 (list (widget-color-choice-list)) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3477 (completion (try-completion prefix list))) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3478 (cond ((eq completion t) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3479 (message "Exact match.")) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3480 ((null completion) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3481 (error "Can't find completion for \"%s\"" prefix)) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3482 ((not (string-equal prefix completion)) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3483 (insert-and-inherit (substring completion (length prefix)))) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3484 (t |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3485 (message "Making completion list...") |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3486 (let ((list (all-completions prefix list nil))) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3487 (with-output-to-temp-buffer "*Completions*" |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3488 (display-completion-list list))) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3489 (message "Making completion list...done"))))) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3490 |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3491 (defun widget-color-sample-face-get (widget) |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3492 (let* ((value (condition-case nil |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3493 (widget-value widget) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3494 (error (widget-get widget :value)))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3495 (symbol (intern (concat "fg:" value)))) |
21338
f94e2fdb6617
(widget-beginning-of-line): Don't set zmacs-region-stays.
Richard M. Stallman <rms@gnu.org>
parents:
21337
diff
changeset
|
3496 (condition-case nil |
f94e2fdb6617
(widget-beginning-of-line): Don't set zmacs-region-stays.
Richard M. Stallman <rms@gnu.org>
parents:
21337
diff
changeset
|
3497 (facemenu-get-face symbol) |
f94e2fdb6617
(widget-beginning-of-line): Don't set zmacs-region-stays.
Richard M. Stallman <rms@gnu.org>
parents:
21337
diff
changeset
|
3498 (error 'default)))) |
17334 | 3499 |
3500 (defvar widget-color-choice-list nil) | |
3501 ;; Variable holding the possible colors. | |
3502 | |
3503 (defun widget-color-choice-list () | |
3504 (unless widget-color-choice-list | |
3505 (setq widget-color-choice-list | |
21338
f94e2fdb6617
(widget-beginning-of-line): Don't set zmacs-region-stays.
Richard M. Stallman <rms@gnu.org>
parents:
21337
diff
changeset
|
3506 (mapcar '(lambda (color) (list color)) |
f94e2fdb6617
(widget-beginning-of-line): Don't set zmacs-region-stays.
Richard M. Stallman <rms@gnu.org>
parents:
21337
diff
changeset
|
3507 (x-defined-colors)))) |
17334 | 3508 widget-color-choice-list) |
3509 | |
3510 (defvar widget-color-history nil | |
3511 "History of entered colors") | |
3512 | |
3513 (defun widget-color-action (widget &optional event) | |
3514 ;; Prompt for a color. | |
3515 (let* ((tag (widget-apply widget :menu-tag-get)) | |
3516 (prompt (concat tag ": ")) | |
19022
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3517 (value (widget-value widget)) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3518 (start (widget-field-start widget)) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3519 (pos (cond ((< (point) start) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3520 0) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3521 ((> (point) (+ start (length value))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3522 (length value)) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3523 (t |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3524 (- (point) start)))) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3525 (answer (if (commandp 'read-color) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3526 (read-color prompt) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3527 (completing-read (concat tag ": ") |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3528 (widget-color-choice-list) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3529 nil nil |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3530 (cons value pos) |
904dcdbb8576
Synched with 1.9951.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18638
diff
changeset
|
3531 'widget-color-history)))) |
17334 | 3532 (unless (zerop (length answer)) |
3533 (widget-value-set widget answer) | |
18090 | 3534 (widget-setup) |
3535 (widget-apply widget :notify widget event)))) | |
17334 | 3536 |
18600
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3537 (defun widget-color-notify (widget child &optional event) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3538 "Update the sample, and notofy the parent." |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3539 (overlay-put (widget-get widget :sample-overlay) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3540 'face (widget-apply widget :sample-face-get)) |
d95acbbb4ac7
Synched with 1.9945.
Per Abrahamsen <abraham@dina.kvl.dk>
parents:
18598
diff
changeset
|
3541 (widget-default-notify widget child event)) |
24107
c222b0bea4f0
(plist, alist): New widget types.
Richard M. Stallman <rms@gnu.org>
parents:
23243
diff
changeset
|
3542 |
17334 | 3543 ;;; The Help Echo |
3544 | |
3545 (defun widget-echo-help-mouse () | |
3546 "Display the help message for the widget under the mouse. | |
3547 Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)" | |
3548 (let* ((pos (mouse-position)) | |
3549 (frame (car pos)) | |
3550 (x (car (cdr pos))) | |
3551 (y (cdr (cdr pos))) | |
3552 (win (window-at x y frame)) | |
3553 (where (coordinates-in-window-p (cons x y) win))) | |
3554 (when (consp where) | |
3555 (save-window-excursion | |
3556 (progn ; save-excursion | |
3557 (select-window win) | |
3558 (let* ((result (compute-motion (window-start win) | |
3559 '(0 . 0) | |
21337
901472ec6f29
Delete some compatibility code.
Richard M. Stallman <rms@gnu.org>
parents:
21068
diff
changeset
|
3560 (point-max) |
17334 | 3561 where |
3562 (window-width win) | |
3563 (cons (window-hscroll) 0) | |
3564 win))) | |
3565 (when (and (eq (nth 1 result) x) | |
3566 (eq (nth 2 result) y)) | |
3567 (widget-echo-help (nth 0 result)))))))) | |
3568 (unless track-mouse | |
3569 (setq track-mouse t) | |
3570 (add-hook 'post-command-hook 'widget-stop-mouse-tracking))) | |
3571 | |
3572 (defun widget-stop-mouse-tracking (&rest args) | |
3573 "Stop the mouse tracking done while idle." | |
3574 (remove-hook 'post-command-hook 'widget-stop-mouse-tracking) | |
3575 (setq track-mouse nil)) | |
3576 | |
3577 (defun widget-at (pos) | |
3578 "The button or field at POS." | |
18090 | 3579 (or (get-char-property pos 'button) |
3580 (get-char-property pos 'field))) | |
17334 | 3581 |
3582 (defun widget-echo-help (pos) | |
3583 "Display the help echo for widget at POS." | |
3584 (let* ((widget (widget-at pos)) | |
3585 (help-echo (and widget (widget-get widget :help-echo)))) | |
3586 (cond ((stringp help-echo) | |
3587 (message "%s" help-echo)) | |
3588 ((and (symbolp help-echo) (fboundp help-echo) | |
3589 (stringp (setq help-echo (funcall help-echo widget)))) | |
3590 (message "%s" help-echo))))) | |
3591 | |
3592 ;;; The End: | |
3593 | |
3594 (provide 'wid-edit) | |
3595 | |
3596 ;; wid-edit.el ends here |