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