|
18
|
1 ;;; custom-edit.el --- Tools for customization Emacs.
|
|
|
2 ;;
|
|
22
|
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
|
|
18
|
4 ;;
|
|
|
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
|
|
|
6 ;; Keywords: help, faces
|
|
22
|
7 ;; Version: 1.40
|
|
18
|
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
|
|
|
9
|
|
|
10 ;;; Commentary:
|
|
|
11 ;;
|
|
|
12 ;; See `custom.el'.
|
|
|
13
|
|
|
14 ;;; Code:
|
|
|
15
|
|
|
16 (require 'custom)
|
|
|
17 (require 'widget-edit)
|
|
|
18 (require 'easymenu)
|
|
|
19
|
|
|
20 (define-widget-keywords :custom-prefixes :custom-menu :custom-show
|
|
|
21 :custom-magic :custom-state :custom-level :custom-form
|
|
|
22 :custom-set :custom-save :custom-reset-current :custom-reset-saved
|
|
|
23 :custom-reset-factory)
|
|
|
24
|
|
|
25 ;;; Utilities.
|
|
|
26
|
|
|
27 (defun custom-quote (sexp)
|
|
|
28 "Quote SEXP iff it is not self quoting."
|
|
|
29 (if (or (memq sexp '(t nil))
|
|
|
30 (and (symbolp sexp)
|
|
|
31 (eq (aref (symbol-name sexp) 0) ?:))
|
|
|
32 (and (listp sexp)
|
|
|
33 (memq (car sexp) '(lambda)))
|
|
|
34 (stringp sexp)
|
|
|
35 (numberp sexp)
|
|
|
36 (and (fboundp 'characterp)
|
|
|
37 (characterp sexp)))
|
|
|
38 sexp
|
|
|
39 (list 'quote sexp)))
|
|
|
40
|
|
|
41 (defun custom-split-regexp-maybe (regexp)
|
|
|
42 "If REGEXP is a string, split it to a list at `\\|'.
|
|
|
43 You can get the original back with from the result with:
|
|
|
44 (mapconcat 'identity result \"\\|\")
|
|
|
45
|
|
|
46 IF REGEXP is not a string, return it unchanged."
|
|
|
47 (if (stringp regexp)
|
|
|
48 (let ((start 0)
|
|
|
49 all)
|
|
|
50 (while (string-match "\\\\|" regexp start)
|
|
|
51 (setq all (cons (substring regexp start (match-beginning 0)) all)
|
|
|
52 start (match-end 0)))
|
|
|
53 (nreverse (cons (substring regexp start) all)))
|
|
|
54 regexp))
|
|
|
55
|
|
|
56 (defvar custom-prefix-list nil
|
|
|
57 "List of prefixes that should be ignored by `custom-unlispify'")
|
|
|
58
|
|
|
59 (defcustom custom-unlispify-menu-entries t
|
|
|
60 "Display menu entries as words instead of symbols if non nil."
|
|
|
61 :group 'customize
|
|
|
62 :type 'boolean)
|
|
|
63
|
|
|
64 (defun custom-unlispify-menu-entry (symbol &optional no-suffix)
|
|
|
65 "Convert symbol into a menu entry."
|
|
|
66 (cond ((not custom-unlispify-menu-entries)
|
|
|
67 (symbol-name symbol))
|
|
|
68 ((get symbol 'custom-tag)
|
|
|
69 (if no-suffix
|
|
|
70 (get symbol 'custom-tag)
|
|
|
71 (concat (get symbol 'custom-tag) "...")))
|
|
|
72 (t
|
|
|
73 (save-excursion
|
|
|
74 (set-buffer (get-buffer-create " *Custom-Work*"))
|
|
|
75 (erase-buffer)
|
|
|
76 (princ symbol (current-buffer))
|
|
|
77 (goto-char (point-min))
|
|
|
78 (let ((prefixes custom-prefix-list)
|
|
|
79 prefix)
|
|
|
80 (while prefixes
|
|
|
81 (setq prefix (car prefixes))
|
|
|
82 (if (search-forward prefix (+ (point) (length prefix)) t)
|
|
|
83 (progn
|
|
|
84 (setq prefixes nil)
|
|
|
85 (delete-region (point-min) (point)))
|
|
|
86 (setq prefixes (cdr prefixes)))))
|
|
|
87 (subst-char-in-region (point-min) (point-max) ?- ?\ t)
|
|
|
88 (capitalize-region (point-min) (point-max))
|
|
|
89 (unless no-suffix
|
|
|
90 (goto-char (point-max))
|
|
|
91 (insert "..."))
|
|
|
92 (buffer-string)))))
|
|
|
93
|
|
|
94 (defcustom custom-unlispify-tag-names t
|
|
|
95 "Display tag names as words instead of symbols if non nil."
|
|
|
96 :group 'customize
|
|
|
97 :type 'boolean)
|
|
|
98
|
|
|
99 (defun custom-unlispify-tag-name (symbol)
|
|
|
100 "Convert symbol into a menu entry."
|
|
|
101 (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
|
|
|
102 (custom-unlispify-menu-entry symbol t)))
|
|
|
103
|
|
|
104 (defun custom-prefix-add (symbol prefixes)
|
|
|
105 ;; Addd SYMBOL to list of ignored PREFIXES.
|
|
|
106 (cons (or (get symbol 'custom-prefix)
|
|
|
107 (concat (symbol-name symbol) "-"))
|
|
|
108 prefixes))
|
|
|
109
|
|
|
110 ;;; The Custom Mode.
|
|
|
111
|
|
|
112 (defvar custom-options nil
|
|
|
113 "Customization widgets in the current buffer.")
|
|
|
114
|
|
|
115 (defvar custom-mode-map nil
|
|
|
116 "Keymap for `custom-mode'.")
|
|
|
117
|
|
|
118 (unless custom-mode-map
|
|
|
119 (setq custom-mode-map (make-sparse-keymap))
|
|
|
120 (set-keymap-parent custom-mode-map widget-keymap))
|
|
|
121
|
|
|
122 (easy-menu-define custom-mode-menu
|
|
|
123 custom-mode-map
|
|
|
124 "Menu used in customization buffers."
|
|
|
125 '("Custom"
|
|
|
126 ["Set" custom-set t]
|
|
|
127 ["Save" custom-save t]
|
|
|
128 ["Reset to Current" custom-reset-current t]
|
|
|
129 ["Reset to Saved" custom-reset-saved t]
|
|
|
130 ["Reset to Factory Settings" custom-reset-factory t]
|
|
|
131 ["Info" (Info-goto-node "(custom)The Customization Buffer") t]))
|
|
|
132
|
|
|
133 (defcustom custom-mode-hook nil
|
|
|
134 "Hook called when entering custom-mode."
|
|
|
135 :type 'hook
|
|
|
136 :group 'customize)
|
|
|
137
|
|
|
138 (defun custom-mode ()
|
|
|
139 "Major mode for editing customization buffers.
|
|
|
140
|
|
|
141 The following commands are available:
|
|
|
142
|
|
|
143 \\[widget-forward] Move to next button or editable field.
|
|
|
144 \\[widget-backward] Move to previous button or editable field.
|
|
|
145 \\[widget-button-click] Activate button under the mouse pointer.
|
|
|
146 \\[widget-button-press] Activate button under point.
|
|
|
147 \\[custom-set] Set all modifications.
|
|
|
148 \\[custom-save] Make all modifications default.
|
|
|
149 \\[custom-reset-current] Reset all modified options.
|
|
|
150 \\[custom-reset-saved] Reset all modified or set options.
|
|
|
151 \\[custom-reset-factory] Reset all options.
|
|
|
152
|
|
|
153 Entry to this mode calls the value of `custom-mode-hook'
|
|
|
154 if that value is non-nil."
|
|
|
155 (kill-all-local-variables)
|
|
|
156 (setq major-mode 'custom-mode
|
|
|
157 mode-name "Custom")
|
|
|
158 (use-local-map custom-mode-map)
|
|
22
|
159 (easy-menu-add custom-mode-menu)
|
|
18
|
160 (make-local-variable 'custom-options)
|
|
|
161 (run-hooks 'custom-mode-hook))
|
|
|
162
|
|
|
163 ;;; Custom Mode Commands.
|
|
|
164
|
|
|
165 (defun custom-set ()
|
|
|
166 "Set changes in all modified options."
|
|
|
167 (interactive)
|
|
|
168 (let ((children custom-options))
|
|
|
169 (mapcar (lambda (child)
|
|
|
170 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
171 (widget-apply child :custom-set)))
|
|
|
172 children)))
|
|
|
173
|
|
|
174 (defun custom-save ()
|
|
|
175 "Set all modified group members and save them."
|
|
|
176 (interactive)
|
|
|
177 (let ((children custom-options))
|
|
|
178 (mapcar (lambda (child)
|
|
|
179 (when (memq (widget-get child :custom-state) '(modified set))
|
|
|
180 (widget-apply child :custom-save)))
|
|
|
181 children))
|
|
|
182 (custom-save-all))
|
|
|
183
|
|
|
184 (defvar custom-reset-menu
|
|
|
185 '(("Current" . custom-reset-current)
|
|
|
186 ("Saved" . custom-reset-saved)
|
|
|
187 ("Factory Settings" . custom-reset-factory))
|
|
|
188 "Alist of actions for the `Reset' button.
|
|
|
189 The key is a string containing the name of the action, the value is a
|
|
|
190 lisp function taking the widget as an element which will be called
|
|
|
191 when the action is chosen.")
|
|
|
192
|
|
|
193 (defun custom-reset (event)
|
|
|
194 "Select item from reset menu."
|
|
|
195 (let* ((completion-ignore-case t)
|
|
|
196 (answer (widget-choose "Reset to"
|
|
|
197 custom-reset-menu
|
|
|
198 event)))
|
|
|
199 (if answer
|
|
|
200 (funcall answer))))
|
|
|
201
|
|
|
202 (defun custom-reset-current ()
|
|
|
203 "Reset all modified group members to their current value."
|
|
|
204 (interactive)
|
|
|
205 (let ((children custom-options))
|
|
|
206 (mapcar (lambda (child)
|
|
|
207 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
208 (widget-apply child :custom-reset-current)))
|
|
|
209 children)))
|
|
|
210
|
|
|
211 (defun custom-reset-saved ()
|
|
|
212 "Reset all modified or set group members to their saved value."
|
|
|
213 (interactive)
|
|
|
214 (let ((children custom-options))
|
|
|
215 (mapcar (lambda (child)
|
|
|
216 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
217 (widget-apply child :custom-reset-current)))
|
|
|
218 children)))
|
|
|
219
|
|
|
220 (defun custom-reset-factory ()
|
|
|
221 "Reset all modified, set, or saved group members to their factory settings."
|
|
|
222 (interactive)
|
|
|
223 (let ((children custom-options))
|
|
|
224 (mapcar (lambda (child)
|
|
|
225 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
226 (widget-apply child :custom-reset-current)))
|
|
|
227 children)))
|
|
|
228
|
|
|
229 ;;; The Customize Commands
|
|
|
230
|
|
|
231 ;;;###autoload
|
|
|
232 (defun customize (symbol)
|
|
|
233 "Customize SYMBOL, which must be a customization group."
|
|
|
234 (interactive (list (completing-read "Customize group: (default emacs) "
|
|
|
235 obarray
|
|
|
236 (lambda (symbol)
|
|
|
237 (get symbol 'custom-group))
|
|
|
238 t)))
|
|
|
239
|
|
|
240 (when (stringp symbol)
|
|
|
241 (if (string-equal "" symbol)
|
|
|
242 (setq symbol 'emacs)
|
|
|
243 (setq symbol (intern symbol))))
|
|
|
244 (custom-buffer-create (list (list symbol 'custom-group))))
|
|
|
245
|
|
|
246 ;;;###autoload
|
|
|
247 (defun customize-variable (symbol)
|
|
|
248 "Customize SYMBOL, which must be a variable."
|
|
|
249 (interactive
|
|
|
250 ;; Code stolen from `help.el'.
|
|
|
251 (let ((v (variable-at-point))
|
|
|
252 (enable-recursive-minibuffers t)
|
|
|
253 val)
|
|
|
254 (setq val (completing-read
|
|
|
255 (if v
|
|
|
256 (format "Customize variable (default %s): " v)
|
|
|
257 "Customize variable: ")
|
|
|
258 obarray 'boundp t))
|
|
|
259 (list (if (equal val "")
|
|
|
260 v (intern val)))))
|
|
|
261 (custom-buffer-create (list (list symbol 'custom-variable))))
|
|
|
262
|
|
|
263 ;;;###autoload
|
|
|
264 (defun customize-face (symbol)
|
|
|
265 "Customize FACE."
|
|
|
266 (interactive (list (completing-read "Customize face: "
|
|
|
267 obarray 'custom-facep)))
|
|
|
268 (if (stringp symbol)
|
|
|
269 (setq symbol (intern symbol)))
|
|
|
270 (unless (symbolp symbol)
|
|
|
271 (error "Should be a symbol %S" symbol))
|
|
|
272 (custom-buffer-create (list (list symbol 'custom-face))))
|
|
|
273
|
|
|
274 ;;;###autoload
|
|
|
275 (defun customize-customized ()
|
|
|
276 "Customize all already customized user options."
|
|
|
277 (interactive)
|
|
|
278 (let ((found nil))
|
|
|
279 (mapatoms (lambda (symbol)
|
|
|
280 (and (get symbol 'saved-face)
|
|
|
281 (custom-facep symbol)
|
|
|
282 (setq found (cons (list symbol 'custom-face) found)))
|
|
|
283 (and (get symbol 'saved-value)
|
|
|
284 (boundp symbol)
|
|
|
285 (setq found
|
|
|
286 (cons (list symbol 'custom-variable) found)))))
|
|
|
287 (if found
|
|
|
288 (custom-buffer-create found)
|
|
|
289 (error "No customized user options"))))
|
|
|
290
|
|
|
291 ;;;###autoload
|
|
|
292 (defun customize-apropos (regexp &optional all)
|
|
|
293 "Customize all user options matching REGEXP.
|
|
|
294 If ALL (e.g., started with a prefix key), include options which are not
|
|
|
295 user-settable."
|
|
|
296 (interactive "sCustomize regexp: \nP")
|
|
|
297 (let ((found nil))
|
|
|
298 (mapatoms (lambda (symbol)
|
|
|
299 (when (string-match regexp (symbol-name symbol))
|
|
|
300 (when (get symbol 'custom-group)
|
|
|
301 (setq found (cons (list symbol 'custom-group) found)))
|
|
|
302 (when (custom-facep symbol)
|
|
|
303 (setq found (cons (list symbol 'custom-face) found)))
|
|
|
304 (when (and (boundp symbol)
|
|
|
305 (or (get symbol 'saved-value)
|
|
|
306 (get symbol 'factory-value)
|
|
|
307 (if all
|
|
|
308 (get symbol 'variable-documentation)
|
|
|
309 (user-variable-p symbol))))
|
|
|
310 (setq found
|
|
|
311 (cons (list symbol 'custom-variable) found))))))
|
|
|
312 (if found
|
|
|
313 (custom-buffer-create found)
|
|
|
314 (error "No matches"))))
|
|
|
315
|
|
|
316 ;;;###autoload
|
|
|
317 (defun custom-buffer-create (options)
|
|
|
318 "Create a buffer containing OPTIONS.
|
|
|
319 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
|
|
|
320 SYMBOL is a customization option, and WIDGET is a widget for editing
|
|
|
321 that option."
|
|
|
322 (kill-buffer (get-buffer-create "*Customization*"))
|
|
|
323 (switch-to-buffer (get-buffer-create "*Customization*"))
|
|
|
324 (custom-mode)
|
|
|
325 (widget-insert "This is a customization buffer.
|
|
|
326 Push RET or click mouse-2 on the word ")
|
|
|
327 (widget-create 'info-link
|
|
|
328 :tag "help"
|
|
|
329 :help-echo "Push me for help."
|
|
|
330 "(custom)The Customization Buffer")
|
|
|
331 (widget-insert " for more information.\n\n")
|
|
|
332 (setq custom-options
|
|
|
333 (mapcar (lambda (entry)
|
|
|
334 (prog1
|
|
|
335 (if (> (length options) 1)
|
|
|
336 (widget-create (nth 1 entry)
|
|
|
337 :tag (custom-unlispify-tag-name
|
|
|
338 (nth 0 entry))
|
|
|
339 :value (nth 0 entry))
|
|
|
340 ;; If there is only one entry, don't hide it!
|
|
|
341 (widget-create (nth 1 entry)
|
|
|
342 :custom-state 'unknown
|
|
|
343 :tag (custom-unlispify-tag-name
|
|
|
344 (nth 0 entry))
|
|
|
345 :value (nth 0 entry)))
|
|
|
346 (unless (eq (preceding-char) ?\n)
|
|
|
347 (widget-insert "\n"))
|
|
|
348 (widget-insert "\n")))
|
|
|
349 options))
|
|
|
350 (mapcar 'custom-magic-reset custom-options)
|
|
|
351 (widget-create 'push-button
|
|
|
352 :tag "Set"
|
|
|
353 :help-echo "Push me to set all modifications."
|
|
|
354 :action (lambda (widget &optional event)
|
|
|
355 (custom-set)))
|
|
|
356 (widget-insert " ")
|
|
|
357 (widget-create 'push-button
|
|
|
358 :tag "Save"
|
|
|
359 :help-echo "Push me to make the modifications default."
|
|
|
360 :action (lambda (widget &optional event)
|
|
|
361 (custom-save)))
|
|
|
362 (widget-insert " ")
|
|
|
363 (widget-create 'push-button
|
|
|
364 :tag "Reset"
|
|
22
|
365 :help-echo "Push me to undo all modifications."
|
|
18
|
366 :action (lambda (widget &optional event)
|
|
|
367 (custom-reset event)))
|
|
22
|
368 (widget-insert " ")
|
|
|
369 (widget-create 'push-button
|
|
|
370 :tag "Done"
|
|
|
371 :help-echo "Push me to bury the buffer."
|
|
|
372 :action (lambda (widget &optional event)
|
|
|
373 (bury-buffer)))
|
|
18
|
374 (widget-insert "\n")
|
|
|
375 (widget-setup))
|
|
|
376
|
|
|
377 ;;; Modification of Basic Widgets.
|
|
|
378 ;;
|
|
|
379 ;; We add extra properties to the basic widgets needed here. This is
|
|
|
380 ;; fine, as long as we are careful to stay within out own namespace.
|
|
|
381 ;;
|
|
|
382 ;; We want simple widgets to be displayed by default, but complex
|
|
|
383 ;; widgets to be hidden.
|
|
|
384
|
|
|
385 (widget-put (get 'item 'widget-type) :custom-show t)
|
|
|
386 (widget-put (get 'editable-field 'widget-type)
|
|
|
387 :custom-show (lambda (widget value)
|
|
|
388 (let ((pp (pp-to-string value)))
|
|
|
389 (cond ((string-match "\n" pp)
|
|
|
390 nil)
|
|
|
391 ((> (length pp) 40)
|
|
|
392 nil)
|
|
|
393 (t t)))))
|
|
|
394 (widget-put (get 'menu-choice 'widget-type) :custom-show t)
|
|
|
395
|
|
|
396 ;;; The `custom-manual' Widget.
|
|
|
397
|
|
|
398 (define-widget 'custom-manual 'info-link
|
|
|
399 "Link to the manual entry for this customization option."
|
|
|
400 :help-echo "Push me to read the manual."
|
|
|
401 :tag "Manual")
|
|
|
402
|
|
|
403 ;;; The `custom-magic' Widget.
|
|
|
404
|
|
|
405 (defface custom-invalid-face '((((class color))
|
|
|
406 (:foreground "yellow" :background "red"))
|
|
|
407 (t
|
|
|
408 (:bold t :italic t :underline t)))
|
|
|
409 "Face used when the customize item is invalid.")
|
|
|
410
|
|
|
411 (defface custom-rogue-face '((((class color))
|
|
|
412 (:foreground "pink" :background "black"))
|
|
|
413 (t
|
|
|
414 (:underline t)))
|
|
|
415 "Face used when the customize item is not defined for customization.")
|
|
|
416
|
|
|
417 (defface custom-modified-face '((((class color))
|
|
|
418 (:foreground "white" :background "blue"))
|
|
|
419 (t
|
|
|
420 (:italic t :bold)))
|
|
|
421 "Face used when the customize item has been modified.")
|
|
|
422
|
|
|
423 (defface custom-set-face '((((class color))
|
|
|
424 (:foreground "blue" :background "white"))
|
|
|
425 (t
|
|
|
426 (:italic t)))
|
|
|
427 "Face used when the customize item has been set.")
|
|
|
428
|
|
|
429 (defface custom-changed-face '((((class color))
|
|
|
430 (:foreground "white" :background "blue"))
|
|
|
431 (t
|
|
|
432 (:italic t)))
|
|
|
433 "Face used when the customize item has been changed.")
|
|
|
434
|
|
|
435 (defface custom-saved-face '((t (:underline t)))
|
|
|
436 "Face used when the customize item has been saved.")
|
|
|
437
|
|
|
438 (defcustom custom-magic-alist '((nil "#" underline "\
|
|
|
439 uninitialized, you should not see this.")
|
|
|
440 (unknown "?" italic "\
|
|
|
441 unknown, you should not see this.")
|
|
|
442 (hidden "-" default "\
|
|
|
443 hidden, press the state button to show.")
|
|
|
444 (invalid "x" custom-invalid-face "\
|
|
|
445 the value displayed for this item is invalid and cannot be set.")
|
|
|
446 (modified "*" custom-modified-face "\
|
|
|
447 you have edited the item, and can now set it.")
|
|
|
448 (set "+" custom-set-face "\
|
|
|
449 you have set this item, but not saved it.")
|
|
|
450 (changed ":" custom-changed-face "\
|
|
|
451 this item has been changed outside customize.")
|
|
|
452 (saved "!" custom-saved-face "\
|
|
|
453 this item has been saved.")
|
|
|
454 (rogue "@" custom-rogue-face "\
|
|
|
455 this item is not prepared for customization.")
|
|
|
456 (factory " " nil "\
|
|
|
457 this item is unchanged from its factory setting."))
|
|
|
458 "Alist of customize option states.
|
|
|
459 Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where
|
|
|
460
|
|
|
461 STATE is one of the following symbols:
|
|
|
462
|
|
|
463 `nil'
|
|
|
464 For internal use, should never occur.
|
|
|
465 `unknown'
|
|
|
466 For internal use, should never occur.
|
|
|
467 `hidden'
|
|
|
468 This item is not being displayed.
|
|
|
469 `invalid'
|
|
|
470 This item is modified, but has an invalid form.
|
|
|
471 `modified'
|
|
|
472 This item is modified, and has a valid form.
|
|
|
473 `set'
|
|
|
474 This item has been set but not saved.
|
|
|
475 `changed'
|
|
|
476 The current value of this item has been changed temporarily.
|
|
|
477 `saved'
|
|
|
478 This item is marked for saving.
|
|
|
479 `rogue'
|
|
|
480 This item has no customization information.
|
|
|
481 `factory'
|
|
|
482 This item is unchanged from the factory default.
|
|
|
483
|
|
|
484 MAGIC is a string used to present that state.
|
|
|
485
|
|
|
486 FACE is a face used to present the state.
|
|
|
487
|
|
|
488 DESCRIPTION is a string describing the state.
|
|
|
489
|
|
|
490 The list should be sorted most significant first."
|
|
|
491 :type '(list (checklist :inline t
|
|
|
492 (group (const nil)
|
|
|
493 (string :tag "Magic")
|
|
|
494 face
|
|
|
495 (string :tag "Description"))
|
|
|
496 (group (const unknown)
|
|
|
497 (string :tag "Magic")
|
|
|
498 face
|
|
|
499 (string :tag "Description"))
|
|
|
500 (group (const hidden)
|
|
|
501 (string :tag "Magic")
|
|
|
502 face
|
|
|
503 (string :tag "Description"))
|
|
|
504 (group (const invalid)
|
|
|
505 (string :tag "Magic")
|
|
|
506 face
|
|
|
507 (string :tag "Description"))
|
|
|
508 (group (const modified)
|
|
|
509 (string :tag "Magic")
|
|
|
510 face
|
|
|
511 (string :tag "Description"))
|
|
|
512 (group (const set)
|
|
|
513 (string :tag "Magic")
|
|
|
514 face
|
|
|
515 (string :tag "Description"))
|
|
|
516 (group (const changed)
|
|
|
517 (string :tag "Magic")
|
|
|
518 face
|
|
|
519 (string :tag "Description"))
|
|
|
520 (group (const saved)
|
|
|
521 (string :tag "Magic")
|
|
|
522 face
|
|
|
523 (string :tag "Description"))
|
|
|
524 (group (const rogue)
|
|
|
525 (string :tag "Magic")
|
|
|
526 face
|
|
|
527 (string :tag "Description"))
|
|
|
528 (group (const factory)
|
|
|
529 (string :tag "Magic")
|
|
|
530 face
|
|
|
531 (string :tag "Description")))
|
|
|
532 (editable-list :inline t
|
|
|
533 (group symbol
|
|
|
534 (string :tag "Magic")
|
|
|
535 face
|
|
|
536 (string :tag "Description"))))
|
|
|
537 :group 'customize)
|
|
|
538
|
|
|
539 (defcustom custom-magic-show 'long
|
|
|
540 "Show long description of the state of each customization option."
|
|
|
541 :type '(choice (const :tag "no" nil)
|
|
|
542 (const short)
|
|
|
543 (const long))
|
|
|
544 :group 'customize)
|
|
|
545
|
|
|
546 (defcustom custom-magic-show-button t
|
|
|
547 "Show a magic button indicating the state of each customization option."
|
|
|
548 :type 'boolean
|
|
|
549 :group 'customize)
|
|
|
550
|
|
|
551 (define-widget 'custom-magic 'default
|
|
|
552 "Show and manipulate state for a customization option."
|
|
|
553 :format "%v"
|
|
|
554 :action 'widget-choice-item-action
|
|
|
555 :value-get 'ignore
|
|
|
556 :value-create 'custom-magic-value-create
|
|
|
557 :value-delete 'widget-children-value-delete)
|
|
|
558
|
|
|
559 (defun custom-magic-value-create (widget)
|
|
|
560 ;; Create compact status report for WIDGET.
|
|
|
561 (let* ((parent (widget-get widget :parent))
|
|
|
562 (state (widget-get parent :custom-state))
|
|
|
563 (entry (assq state custom-magic-alist))
|
|
|
564 (magic (nth 1 entry))
|
|
|
565 (face (nth 2 entry))
|
|
|
566 (text (nth 3 entry))
|
|
|
567 (lisp (eq (widget-get parent :custom-form) 'lisp))
|
|
|
568 children)
|
|
|
569 (when custom-magic-show
|
|
|
570 (push (widget-create-child-and-convert widget 'choice-item
|
|
|
571 :help-echo "\
|
|
|
572 Push me to change the state of this item."
|
|
|
573 :format "%[%t%]"
|
|
|
574 :tag "State")
|
|
|
575 children)
|
|
|
576 (insert ": ")
|
|
|
577 (if (eq custom-magic-show 'long)
|
|
|
578 (insert text)
|
|
|
579 (insert (symbol-name state)))
|
|
|
580 (when lisp
|
|
|
581 (insert " (lisp)"))
|
|
|
582 (insert "\n"))
|
|
|
583 (when custom-magic-show-button
|
|
|
584 (when custom-magic-show
|
|
|
585 (let ((indent (widget-get parent :indent)))
|
|
|
586 (when indent
|
|
|
587 (insert-char ? indent))))
|
|
|
588 (push (widget-create-child-and-convert widget 'choice-item
|
|
|
589 :button-face face
|
|
|
590 :help-echo "\
|
|
|
591 Push me to change the state."
|
|
|
592 :format "%[%t%]"
|
|
|
593 :tag (if lisp
|
|
|
594 (concat "(" magic ")")
|
|
|
595 (concat "[" magic "]")))
|
|
|
596 children)
|
|
|
597 (insert " "))
|
|
|
598 (widget-put widget :children children)))
|
|
|
599
|
|
|
600 (defun custom-magic-reset (widget)
|
|
|
601 "Redraw the :custom-magic property of WIDGET."
|
|
|
602 (let ((magic (widget-get widget :custom-magic)))
|
|
|
603 (widget-value-set magic (widget-value magic))))
|
|
|
604
|
|
|
605 ;;; The `custom-level' Widget.
|
|
|
606
|
|
|
607 (define-widget 'custom-level 'item
|
|
|
608 "The custom level buttons."
|
|
|
609 :format "%[%t%]"
|
|
|
610 :help-echo "Push me to expand or collapse this item."
|
|
|
611 :action 'custom-level-action)
|
|
|
612
|
|
|
613 (defun custom-level-action (widget &optional event)
|
|
|
614 "Toggle visibility for parent to WIDGET."
|
|
|
615 (let* ((parent (widget-get widget :parent))
|
|
|
616 (state (widget-get parent :custom-state)))
|
|
|
617 (cond ((memq state '(invalid modified))
|
|
|
618 (error "There are unset changes"))
|
|
|
619 ((eq state 'hidden)
|
|
|
620 (widget-put parent :custom-state 'unknown))
|
|
|
621 (t
|
|
|
622 (widget-put parent :custom-state 'hidden)))
|
|
|
623 (custom-redraw parent)))
|
|
|
624
|
|
|
625 ;;; The `custom' Widget.
|
|
|
626
|
|
|
627 (define-widget 'custom 'default
|
|
|
628 "Customize a user option."
|
|
|
629 :convert-widget 'custom-convert-widget
|
|
|
630 :format "%l%[%t%]: %v%m%h%a"
|
|
|
631 :format-handler 'custom-format-handler
|
|
|
632 :notify 'custom-notify
|
|
|
633 :custom-level 1
|
|
|
634 :custom-state 'hidden
|
|
|
635 :documentation-property 'widget-subclass-responsibility
|
|
|
636 :value-create 'widget-subclass-responsibility
|
|
|
637 :value-delete 'widget-children-value-delete
|
|
|
638 :value-get 'widget-item-value-get
|
|
|
639 :validate 'widget-editable-list-validate
|
|
|
640 :match (lambda (widget value) (symbolp value)))
|
|
|
641
|
|
|
642 (defun custom-convert-widget (widget)
|
|
|
643 ;; Initialize :value and :tag from :args in WIDGET.
|
|
|
644 (let ((args (widget-get widget :args)))
|
|
|
645 (when args
|
|
|
646 (widget-put widget :value (widget-apply widget
|
|
|
647 :value-to-internal (car args)))
|
|
|
648 (widget-put widget :tag (custom-unlispify-tag-name (car args)))
|
|
|
649 (widget-put widget :args nil)))
|
|
|
650 widget)
|
|
|
651
|
|
|
652 (defun custom-format-handler (widget escape)
|
|
|
653 ;; We recognize extra escape sequences.
|
|
|
654 (let* ((buttons (widget-get widget :buttons))
|
|
|
655 (state (widget-get widget :custom-state))
|
|
|
656 (level (widget-get widget :custom-level)))
|
|
|
657 (cond ((eq escape ?l)
|
|
|
658 (when level
|
|
|
659 (push (widget-create-child-and-convert
|
|
|
660 widget 'custom-level (make-string level ?*))
|
|
|
661 buttons)
|
|
|
662 (widget-insert " ")
|
|
|
663 (widget-put widget :buttons buttons)))
|
|
|
664 ((eq escape ?L)
|
|
|
665 (when (eq state 'hidden)
|
|
|
666 (widget-insert " ...")))
|
|
|
667 ((eq escape ?m)
|
|
|
668 (and (eq (preceding-char) ?\n)
|
|
|
669 (widget-get widget :indent)
|
|
|
670 (insert-char ? (widget-get widget :indent)))
|
|
|
671 (let ((magic (widget-create-child-and-convert
|
|
|
672 widget 'custom-magic nil)))
|
|
|
673 (widget-put widget :custom-magic magic)
|
|
|
674 (push magic buttons)
|
|
|
675 (widget-put widget :buttons buttons)))
|
|
|
676 ((eq escape ?a)
|
|
|
677 (let* ((symbol (widget-get widget :value))
|
|
|
678 (links (get symbol 'custom-links))
|
|
|
679 (many (> (length links) 2)))
|
|
|
680 (when links
|
|
|
681 (and (eq (preceding-char) ?\n)
|
|
|
682 (widget-get widget :indent)
|
|
|
683 (insert-char ? (widget-get widget :indent)))
|
|
|
684 (insert "See also ")
|
|
|
685 (while links
|
|
|
686 (push (widget-create-child-and-convert widget (car links))
|
|
|
687 buttons)
|
|
|
688 (setq links (cdr links))
|
|
|
689 (cond ((null links)
|
|
|
690 (insert ".\n"))
|
|
|
691 ((null (cdr links))
|
|
|
692 (if many
|
|
|
693 (insert ", and ")
|
|
|
694 (insert " and ")))
|
|
|
695 (t
|
|
|
696 (insert ", "))))
|
|
|
697 (widget-put widget :buttons buttons))))
|
|
|
698 (t
|
|
|
699 (widget-default-format-handler widget escape)))))
|
|
|
700
|
|
|
701 (defun custom-notify (widget &rest args)
|
|
|
702 "Keep track of changes."
|
|
|
703 (widget-put widget :custom-state 'modified)
|
|
|
704 (let ((buffer-undo-list t))
|
|
|
705 (custom-magic-reset widget))
|
|
|
706 (apply 'widget-default-notify widget args))
|
|
|
707
|
|
|
708 (defun custom-redraw (widget)
|
|
|
709 "Redraw WIDGET with current settings."
|
|
22
|
710 (let ((pos (point))
|
|
|
711 (from (marker-position (widget-get widget :from)))
|
|
|
712 (to (marker-position (widget-get widget :to))))
|
|
|
713 (save-excursion
|
|
|
714 (widget-value-set widget (widget-value widget))
|
|
|
715 (custom-redraw-magic widget))
|
|
|
716 (when (and (>= pos from) (<= pos to))
|
|
|
717 (goto-char pos))))
|
|
18
|
718
|
|
|
719 (defun custom-redraw-magic (widget)
|
|
|
720 "Redraw WIDGET state with current settings."
|
|
|
721 (while widget
|
|
|
722 (let ((magic (widget-get widget :custom-magic)))
|
|
|
723 (unless magic
|
|
|
724 (debug))
|
|
|
725 (widget-value-set magic (widget-value magic))
|
|
|
726 (when (setq widget (widget-get widget :group))
|
|
|
727 (custom-group-state-update widget))))
|
|
|
728 (widget-setup))
|
|
|
729
|
|
|
730 (defun custom-show (widget value)
|
|
|
731 "Non-nil if WIDGET should be shown with VALUE by default."
|
|
|
732 (let ((show (widget-get widget :custom-show)))
|
|
|
733 (cond ((null show)
|
|
|
734 nil)
|
|
|
735 ((eq t show)
|
|
|
736 t)
|
|
|
737 (t
|
|
|
738 (funcall show widget value)))))
|
|
|
739
|
|
|
740 (defun custom-load-symbol (symbol)
|
|
|
741 "Load all dependencies for SYMBOL."
|
|
|
742 (let ((loads (get symbol 'custom-loads))
|
|
|
743 load)
|
|
|
744 (while loads
|
|
|
745 (setq load (car loads)
|
|
|
746 loads (cdr loads))
|
|
|
747 (cond ((symbolp load)
|
|
|
748 (condition-case nil
|
|
|
749 (require load)
|
|
|
750 (error nil)))
|
|
|
751 ((assoc load load-history))
|
|
|
752 (t
|
|
|
753 (condition-case nil
|
|
|
754 (load-library load)
|
|
|
755 (error nil)))))))
|
|
|
756
|
|
|
757 (defun custom-load-widget (widget)
|
|
|
758 "Load all dependencies for WIDGET."
|
|
|
759 (custom-load-symbol (widget-value widget)))
|
|
|
760
|
|
|
761 ;;; The `custom-variable' Widget.
|
|
|
762
|
|
|
763 (defface custom-variable-sample-face '((t (:underline t)))
|
|
|
764 "Face used for unpushable variable tags."
|
|
|
765 :group 'customize)
|
|
|
766
|
|
|
767 (defface custom-variable-button-face '((t (:underline t :bold t)))
|
|
|
768 "Face used for pushable variable tags."
|
|
|
769 :group 'customize)
|
|
|
770
|
|
|
771 (define-widget 'custom-variable 'custom
|
|
|
772 "Customize variable."
|
|
|
773 :format "%l%v%m%h%a"
|
|
|
774 :help-echo "Push me to set or reset this variable."
|
|
|
775 :documentation-property 'variable-documentation
|
|
|
776 :custom-state nil
|
|
|
777 :custom-menu 'custom-variable-menu-create
|
|
|
778 :custom-form 'edit
|
|
|
779 :value-create 'custom-variable-value-create
|
|
|
780 :action 'custom-variable-action
|
|
|
781 :custom-set 'custom-variable-set
|
|
|
782 :custom-save 'custom-variable-save
|
|
|
783 :custom-reset-current 'custom-redraw
|
|
|
784 :custom-reset-saved 'custom-variable-reset-saved
|
|
|
785 :custom-reset-factory 'custom-variable-reset-factory)
|
|
|
786
|
|
|
787 (defun custom-variable-value-create (widget)
|
|
|
788 "Here is where you edit the variables value."
|
|
|
789 (custom-load-widget widget)
|
|
|
790 (let* ((buttons (widget-get widget :buttons))
|
|
|
791 (children (widget-get widget :children))
|
|
|
792 (form (widget-get widget :custom-form))
|
|
|
793 (state (widget-get widget :custom-state))
|
|
|
794 (symbol (widget-get widget :value))
|
|
|
795 (options (get symbol 'custom-options))
|
|
|
796 (child-type (or (get symbol 'custom-type) 'sexp))
|
|
|
797 (tag (widget-get widget :tag))
|
|
|
798 (type (let ((tmp (if (listp child-type)
|
|
|
799 (copy-list child-type)
|
|
|
800 (list child-type))))
|
|
|
801 (when options
|
|
|
802 (widget-put tmp :options options))
|
|
|
803 tmp))
|
|
|
804 (conv (widget-convert type))
|
|
|
805 (value (if (default-boundp symbol)
|
|
|
806 (default-value symbol)
|
|
|
807 (widget-get conv :value))))
|
|
|
808 ;; If the widget is new, the child determine whether it is hidden.
|
|
|
809 (cond (state)
|
|
|
810 ((custom-show type value)
|
|
|
811 (setq state 'unknown))
|
|
|
812 (t
|
|
|
813 (setq state 'hidden)))
|
|
|
814 ;; If we don't know the state, see if we need to edit it in lisp form.
|
|
|
815 (when (eq state 'unknown)
|
|
|
816 (unless (widget-apply conv :match value)
|
|
|
817 ;; (widget-apply (widget-convert type) :match value)
|
|
|
818 (setq form 'lisp)))
|
|
|
819 ;; Now we can create the child widget.
|
|
|
820 (cond ((eq state 'hidden)
|
|
|
821 ;; Indicate hidden value.
|
|
|
822 (push (widget-create-child-and-convert
|
|
|
823 widget 'item
|
|
|
824 :format "%{%t%}: ..."
|
|
|
825 :sample-face 'custom-variable-sample-face
|
|
|
826 :tag tag
|
|
|
827 :parent widget)
|
|
|
828 children))
|
|
|
829 ((eq form 'lisp)
|
|
|
830 ;; In lisp mode edit the saved value when possible.
|
|
|
831 (let* ((value (cond ((get symbol 'saved-value)
|
|
|
832 (car (get symbol 'saved-value)))
|
|
|
833 ((get symbol 'factory-value)
|
|
|
834 (car (get symbol 'factory-value)))
|
|
|
835 ((default-boundp symbol)
|
|
|
836 (custom-quote (default-value symbol)))
|
|
|
837 (t
|
|
|
838 (custom-quote (widget-get conv :value))))))
|
|
|
839 (push (widget-create-child-and-convert
|
|
|
840 widget 'sexp
|
|
|
841 :button-face 'custom-variable-button-face
|
|
|
842 :tag (symbol-name symbol)
|
|
|
843 :parent widget
|
|
|
844 :value value)
|
|
|
845 children)))
|
|
|
846 (t
|
|
|
847 ;; Edit mode.
|
|
|
848 (push (widget-create-child-and-convert
|
|
|
849 widget type
|
|
|
850 :tag tag
|
|
|
851 :button-face 'custom-variable-button-face
|
|
|
852 :sample-face 'custom-variable-sample-face
|
|
|
853 :value value)
|
|
|
854 children)))
|
|
|
855 ;; Now update the state.
|
|
|
856 (unless (eq (preceding-char) ?\n)
|
|
|
857 (widget-insert "\n"))
|
|
|
858 (if (eq state 'hidden)
|
|
|
859 (widget-put widget :custom-state state)
|
|
|
860 (custom-variable-state-set widget))
|
|
|
861 (widget-put widget :custom-form form)
|
|
|
862 (widget-put widget :buttons buttons)
|
|
|
863 (widget-put widget :children children)))
|
|
|
864
|
|
|
865 (defun custom-variable-state-set (widget)
|
|
|
866 "Set the state of WIDGET."
|
|
|
867 (let* ((symbol (widget-value widget))
|
|
|
868 (value (if (default-boundp symbol)
|
|
|
869 (default-value symbol)
|
|
|
870 (widget-get widget :value)))
|
|
|
871 tmp
|
|
|
872 (state (cond ((setq tmp (get symbol 'customized-value))
|
|
|
873 (if (condition-case nil
|
|
|
874 (equal value (eval (car tmp)))
|
|
|
875 (error nil))
|
|
22
|
876 'set
|
|
|
877 'changed))
|
|
18
|
878 ((setq tmp (get symbol 'saved-value))
|
|
|
879 (if (condition-case nil
|
|
|
880 (equal value (eval (car tmp)))
|
|
|
881 (error nil))
|
|
|
882 'saved
|
|
22
|
883 'changed))
|
|
18
|
884 ((setq tmp (get symbol 'factory-value))
|
|
|
885 (if (condition-case nil
|
|
|
886 (equal value (eval (car tmp)))
|
|
|
887 (error nil))
|
|
|
888 'factory
|
|
22
|
889 'changed))
|
|
18
|
890 (t 'rogue))))
|
|
|
891 (widget-put widget :custom-state state)))
|
|
|
892
|
|
|
893 (defvar custom-variable-menu
|
|
|
894 '(("Edit" . custom-variable-edit)
|
|
|
895 ("Edit Lisp" . custom-variable-edit-lisp)
|
|
|
896 ("Set" . custom-variable-set)
|
|
|
897 ("Save" . custom-variable-save)
|
|
|
898 ("Reset to Current" . custom-redraw)
|
|
|
899 ("Reset to Saved" . custom-variable-reset-saved)
|
|
|
900 ("Reset to Factory Settings" . custom-variable-reset-factory))
|
|
|
901 "Alist of actions for the `custom-variable' widget.
|
|
|
902 The key is a string containing the name of the action, the value is a
|
|
|
903 lisp function taking the widget as an element which will be called
|
|
|
904 when the action is chosen.")
|
|
|
905
|
|
|
906 (defun custom-variable-action (widget &optional event)
|
|
|
907 "Show the menu for `custom-variable' WIDGET.
|
|
|
908 Optional EVENT is the location for the menu."
|
|
|
909 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
|
910 (progn
|
|
|
911 (widget-put widget :custom-state 'unknown)
|
|
|
912 (custom-redraw widget))
|
|
|
913 (let* ((completion-ignore-case t)
|
|
22
|
914 (answer (widget-choose (capitalize
|
|
|
915 (symbol-name (widget-get widget :value)))
|
|
18
|
916 custom-variable-menu
|
|
|
917 event)))
|
|
|
918 (if answer
|
|
|
919 (funcall answer widget)))))
|
|
|
920
|
|
|
921 (defun custom-variable-edit (widget)
|
|
|
922 "Edit value of WIDGET."
|
|
|
923 (widget-put widget :custom-state 'unknown)
|
|
|
924 (widget-put widget :custom-form 'edit)
|
|
|
925 (custom-redraw widget))
|
|
|
926
|
|
|
927 (defun custom-variable-edit-lisp (widget)
|
|
|
928 "Edit the lisp representation of the value of WIDGET."
|
|
|
929 (widget-put widget :custom-state 'unknown)
|
|
|
930 (widget-put widget :custom-form 'lisp)
|
|
|
931 (custom-redraw widget))
|
|
|
932
|
|
|
933 (defun custom-variable-set (widget)
|
|
|
934 "Set the current value for the variable being edited by WIDGET."
|
|
|
935 (let ((form (widget-get widget :custom-form))
|
|
|
936 (state (widget-get widget :custom-state))
|
|
|
937 (child (car (widget-get widget :children)))
|
|
|
938 (symbol (widget-value widget))
|
|
|
939 val)
|
|
|
940 (cond ((eq state 'hidden)
|
|
|
941 (error "Cannot set hidden variable."))
|
|
|
942 ((setq val (widget-apply child :validate))
|
|
|
943 (goto-char (widget-get val :from))
|
|
|
944 (error "%s" (widget-get val :error)))
|
|
|
945 ((eq form 'lisp)
|
|
|
946 (set symbol (eval (setq val (widget-value child))))
|
|
|
947 (put symbol 'customized-value (list val)))
|
|
|
948 (t
|
|
22
|
949 (set symbol (setq val (widget-value child)))
|
|
18
|
950 (put symbol 'customized-value (list (custom-quote val)))))
|
|
|
951 (custom-variable-state-set widget)
|
|
|
952 (custom-redraw-magic widget)))
|
|
|
953
|
|
|
954 (defun custom-variable-save (widget)
|
|
|
955 "Set the default value for the variable being edited by WIDGET."
|
|
|
956 (let ((form (widget-get widget :custom-form))
|
|
|
957 (state (widget-get widget :custom-state))
|
|
|
958 (child (car (widget-get widget :children)))
|
|
|
959 (symbol (widget-value widget))
|
|
|
960 val)
|
|
|
961 (cond ((eq state 'hidden)
|
|
|
962 (error "Cannot set hidden variable."))
|
|
|
963 ((setq val (widget-apply child :validate))
|
|
|
964 (goto-char (widget-get val :from))
|
|
|
965 (error "%s" (widget-get val :error)))
|
|
|
966 ((eq form 'lisp)
|
|
|
967 (put symbol 'saved-value (list (widget-value child)))
|
|
|
968 (set symbol (eval (widget-value child))))
|
|
|
969 (t
|
|
|
970 (put symbol
|
|
|
971 'saved-value (list (custom-quote (widget-value
|
|
|
972 child))))
|
|
|
973 (set symbol (widget-value child))))
|
|
|
974 (put symbol 'customized-value nil)
|
|
|
975 (custom-save-all)
|
|
|
976 (custom-variable-state-set widget)
|
|
|
977 (custom-redraw-magic widget)))
|
|
|
978
|
|
|
979 (defun custom-variable-reset-saved (widget)
|
|
|
980 "Restore the saved value for the variable being edited by WIDGET."
|
|
|
981 (let ((symbol (widget-value widget)))
|
|
|
982 (if (get symbol 'saved-value)
|
|
|
983 (condition-case nil
|
|
|
984 (set symbol (eval (car (get symbol 'saved-value))))
|
|
|
985 (error nil))
|
|
|
986 (error "No saved value for %s" symbol))
|
|
|
987 (put symbol 'customized-value nil)
|
|
|
988 (widget-put widget :custom-state 'unknown)
|
|
|
989 (custom-redraw widget)))
|
|
|
990
|
|
|
991 (defun custom-variable-reset-factory (widget)
|
|
|
992 "Restore the factory setting for the variable being edited by WIDGET."
|
|
|
993 (let ((symbol (widget-value widget)))
|
|
|
994 (if (get symbol 'factory-value)
|
|
|
995 (set symbol (eval (car (get symbol 'factory-value))))
|
|
|
996 (error "No factory default for %S" symbol))
|
|
|
997 (put symbol 'customized-value nil)
|
|
|
998 (when (get symbol 'saved-value)
|
|
|
999 (put symbol 'saved-value nil)
|
|
|
1000 (custom-save-all))
|
|
|
1001 (widget-put widget :custom-state 'unknown)
|
|
|
1002 (custom-redraw widget)))
|
|
|
1003
|
|
|
1004 ;;; The `custom-face-edit' Widget.
|
|
|
1005
|
|
|
1006 (defvar custom-face-edit-args
|
|
|
1007 (mapcar (lambda (att)
|
|
|
1008 (list 'group
|
|
|
1009 :inline t
|
|
|
1010 (list 'const :format "" :value (nth 0 att))
|
|
|
1011 (nth 1 att)))
|
|
|
1012 custom-face-attributes))
|
|
|
1013
|
|
|
1014 (define-widget 'custom-face-edit 'checklist
|
|
|
1015 "Edit face attributes."
|
|
|
1016 :format "%t: %v"
|
|
|
1017 :tag "Attributes"
|
|
|
1018 :extra-offset 12
|
|
|
1019 :args (mapcar (lambda (att)
|
|
|
1020 (list 'group
|
|
|
1021 :inline t
|
|
|
1022 (list 'const :format "" :value (nth 0 att))
|
|
|
1023 (nth 1 att)))
|
|
|
1024 custom-face-attributes))
|
|
|
1025
|
|
|
1026 ;;; The `custom-display' Widget.
|
|
|
1027
|
|
|
1028 (define-widget 'custom-display 'menu-choice
|
|
|
1029 "Select a display type."
|
|
|
1030 :tag "Display"
|
|
|
1031 :value t
|
|
|
1032 :args '((const :tag "all" t)
|
|
|
1033 (checklist :offset 0
|
|
|
1034 :extra-offset 9
|
|
|
1035 :args ((group (const :format "Type: " type)
|
|
|
1036 (checklist :inline t
|
|
|
1037 :offset 0
|
|
|
1038 (const :format "X "
|
|
|
1039 x)
|
|
|
1040 (const :format "PM "
|
|
|
1041 pm)
|
|
|
1042 (const :format "Win32 "
|
|
|
1043 win32)
|
|
|
1044 (const :format "DOS "
|
|
|
1045 pc)
|
|
|
1046 (const :format "TTY%n"
|
|
|
1047 tty)))
|
|
|
1048 (group (const :format "Class: " class)
|
|
|
1049 (checklist :inline t
|
|
|
1050 :offset 0
|
|
|
1051 (const :format "Color "
|
|
|
1052 color)
|
|
|
1053 (const :format
|
|
|
1054 "Grayscale "
|
|
|
1055 grayscale)
|
|
|
1056 (const :format "Monochrome%n"
|
|
|
1057 mono)))
|
|
|
1058 (group (const :format "Background: " background)
|
|
|
1059 (checklist :inline t
|
|
|
1060 :offset 0
|
|
|
1061 (const :format "Light "
|
|
|
1062 light)
|
|
|
1063 (const :format "Dark\n"
|
|
|
1064 dark)))))))
|
|
|
1065
|
|
|
1066 ;;; The `custom-face' Widget.
|
|
|
1067
|
|
|
1068 (defface custom-face-tag-face '((t (:underline t)))
|
|
|
1069 "Face used for face tags."
|
|
|
1070 :group 'customize)
|
|
|
1071
|
|
|
1072 (define-widget 'custom-face 'custom
|
|
|
1073 "Customize face."
|
|
|
1074 :format "%l%{%t%}: %s%m%h%a%v"
|
|
|
1075 :format-handler 'custom-face-format-handler
|
|
|
1076 :sample-face 'custom-face-tag-face
|
|
|
1077 :help-echo "Push me to set or reset this face."
|
|
|
1078 :documentation-property 'face-documentation
|
|
|
1079 :value-create 'custom-face-value-create
|
|
|
1080 :action 'custom-face-action
|
|
|
1081 :custom-set 'custom-face-set
|
|
|
1082 :custom-save 'custom-face-save
|
|
|
1083 :custom-reset-current 'custom-redraw
|
|
|
1084 :custom-reset-saved 'custom-face-reset-saved
|
|
|
1085 :custom-reset-factory 'custom-face-reset-factory
|
|
|
1086 :custom-menu 'custom-face-menu-create)
|
|
|
1087
|
|
|
1088 (defun custom-face-format-handler (widget escape)
|
|
|
1089 ;; We recognize extra escape sequences.
|
|
|
1090 (let (child
|
|
|
1091 (symbol (widget-get widget :value)))
|
|
|
1092 (cond ((eq escape ?s)
|
|
|
1093 (and (string-match "XEmacs" emacs-version)
|
|
|
1094 ;; XEmacs cannot display initialized faces.
|
|
|
1095 (not (custom-facep symbol))
|
|
|
1096 (copy-face 'custom-face-empty symbol))
|
|
|
1097 (setq child (widget-create-child-and-convert
|
|
|
1098 widget 'item
|
|
|
1099 :format "(%{%t%})\n"
|
|
|
1100 :sample-face symbol
|
|
|
1101 :tag "sample")))
|
|
|
1102 (t
|
|
|
1103 (custom-format-handler widget escape)))
|
|
|
1104 (when child
|
|
|
1105 (widget-put widget
|
|
|
1106 :buttons (cons child (widget-get widget :buttons))))))
|
|
|
1107
|
|
|
1108 (defun custom-face-value-create (widget)
|
|
|
1109 ;; Create a list of the display specifications.
|
|
|
1110 (unless (eq (preceding-char) ?\n)
|
|
|
1111 (insert "\n"))
|
|
|
1112 (when (not (eq (widget-get widget :custom-state) 'hidden))
|
|
|
1113 (custom-load-widget widget)
|
|
|
1114 (let* ((symbol (widget-value widget))
|
|
|
1115 (edit (widget-create-child-and-convert
|
|
|
1116 widget 'editable-list
|
|
|
1117 :entry-format "%i %d %v"
|
|
|
1118 :value (or (get symbol 'saved-face)
|
|
|
1119 (get symbol 'factory-face))
|
|
|
1120 '(group :format "%v"
|
|
|
1121 custom-display custom-face-edit))))
|
|
|
1122 (custom-face-state-set widget)
|
|
|
1123 (widget-put widget :children (list edit)))))
|
|
|
1124
|
|
|
1125 (defvar custom-face-menu
|
|
|
1126 '(("Set" . custom-face-set)
|
|
|
1127 ("Save" . custom-face-save)
|
|
|
1128 ("Reset to Saved" . custom-face-reset-saved)
|
|
|
1129 ("Reset to Factory Setting" . custom-face-reset-factory))
|
|
|
1130 "Alist of actions for the `custom-face' widget.
|
|
|
1131 The key is a string containing the name of the action, the value is a
|
|
|
1132 lisp function taking the widget as an element which will be called
|
|
|
1133 when the action is chosen.")
|
|
|
1134
|
|
|
1135 (defun custom-face-state-set (widget)
|
|
|
1136 "Set the state of WIDGET."
|
|
|
1137 (let ((symbol (widget-value widget)))
|
|
|
1138 (widget-put widget :custom-state (cond ((get symbol 'customized-face)
|
|
|
1139 'set)
|
|
|
1140 ((get symbol 'saved-face)
|
|
|
1141 'saved)
|
|
|
1142 ((get symbol 'factory-face)
|
|
|
1143 'factory)
|
|
|
1144 (t
|
|
|
1145 'rogue)))))
|
|
|
1146
|
|
|
1147 (defun custom-face-action (widget &optional event)
|
|
|
1148 "Show the menu for `custom-face' WIDGET.
|
|
|
1149 Optional EVENT is the location for the menu."
|
|
|
1150 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
|
1151 (progn
|
|
|
1152 (widget-put widget :custom-state 'unknown)
|
|
|
1153 (custom-redraw widget))
|
|
|
1154 (let* ((completion-ignore-case t)
|
|
|
1155 (symbol (widget-get widget :value))
|
|
22
|
1156 (answer (widget-choose (capitalize (symbol-name symbol))
|
|
18
|
1157 custom-face-menu event)))
|
|
|
1158 (if answer
|
|
|
1159 (funcall answer widget)))))
|
|
|
1160
|
|
|
1161 (defun custom-face-set (widget)
|
|
|
1162 "Make the face attributes in WIDGET take effect."
|
|
|
1163 (let* ((symbol (widget-value widget))
|
|
|
1164 (child (car (widget-get widget :children)))
|
|
|
1165 (value (widget-value child)))
|
|
|
1166 (put symbol 'customized-face value)
|
|
|
1167 (custom-face-display-set symbol value)
|
|
|
1168 (custom-face-state-set widget)
|
|
|
1169 (custom-redraw-magic widget)))
|
|
|
1170
|
|
|
1171 (defun custom-face-save (widget)
|
|
|
1172 "Make the face attributes in WIDGET default."
|
|
|
1173 (let* ((symbol (widget-value widget))
|
|
|
1174 (child (car (widget-get widget :children)))
|
|
|
1175 (value (widget-value child)))
|
|
|
1176 (custom-face-display-set symbol value)
|
|
|
1177 (put symbol 'saved-face value)
|
|
|
1178 (put symbol 'customized-face nil)
|
|
|
1179 (custom-face-state-set widget)
|
|
|
1180 (custom-redraw-magic widget)))
|
|
|
1181
|
|
|
1182 (defun custom-face-reset-saved (widget)
|
|
|
1183 "Restore WIDGET to the face's default attributes."
|
|
|
1184 (let* ((symbol (widget-value widget))
|
|
|
1185 (child (car (widget-get widget :children)))
|
|
|
1186 (value (get symbol 'saved-face)))
|
|
|
1187 (unless value
|
|
|
1188 (error "No saved value for this face"))
|
|
|
1189 (put symbol 'customized-face nil)
|
|
|
1190 (custom-face-display-set symbol value)
|
|
|
1191 (widget-value-set child value)
|
|
|
1192 (custom-face-state-set widget)
|
|
|
1193 (custom-redraw-magic widget)))
|
|
|
1194
|
|
|
1195 (defun custom-face-reset-factory (widget)
|
|
|
1196 "Restore WIDGET to the face's factory settings."
|
|
|
1197 (let* ((symbol (widget-value widget))
|
|
|
1198 (child (car (widget-get widget :children)))
|
|
|
1199 (value (get symbol 'factory-face)))
|
|
|
1200 (unless value
|
|
|
1201 (error "No factory default for this face"))
|
|
|
1202 (put symbol 'customized-face nil)
|
|
|
1203 (when (get symbol 'saved-face)
|
|
|
1204 (put symbol 'saved-face nil)
|
|
|
1205 (custom-save-all))
|
|
|
1206 (custom-face-display-set symbol value)
|
|
|
1207 (widget-value-set child value)
|
|
|
1208 (custom-face-state-set widget)
|
|
|
1209 (custom-redraw-magic widget)))
|
|
|
1210
|
|
|
1211 ;;; The `face' Widget.
|
|
|
1212
|
|
|
1213 (define-widget 'face 'default
|
|
|
1214 "Select and customize a face."
|
|
|
1215 :convert-widget 'widget-item-convert-widget
|
|
|
1216 :format "%[%t%]: %v"
|
|
|
1217 :tag "Face"
|
|
|
1218 :value 'default
|
|
|
1219 :value-create 'widget-face-value-create
|
|
|
1220 :value-delete 'widget-face-value-delete
|
|
|
1221 :value-get 'widget-item-value-get
|
|
|
1222 :validate 'widget-editable-list-validate
|
|
|
1223 :action 'widget-face-action
|
|
|
1224 :match '(lambda (widget value) (symbolp value)))
|
|
|
1225
|
|
|
1226 (defun widget-face-value-create (widget)
|
|
|
1227 ;; Create a `custom-face' child.
|
|
|
1228 (let* ((symbol (widget-value widget))
|
|
|
1229 (child (widget-create-child-and-convert
|
|
|
1230 widget 'custom-face
|
|
|
1231 :format "%t %s%m%h%v"
|
|
|
1232 :custom-level nil
|
|
|
1233 :value symbol)))
|
|
|
1234 (custom-magic-reset child)
|
|
|
1235 (setq custom-options (cons child custom-options))
|
|
|
1236 (widget-put widget :children (list child))))
|
|
|
1237
|
|
|
1238 (defun widget-face-value-delete (widget)
|
|
|
1239 ;; Remove the child from the options.
|
|
|
1240 (let ((child (car (widget-get widget :children))))
|
|
|
1241 (setq custom-options (delq child custom-options))
|
|
|
1242 (widget-children-value-delete widget)))
|
|
|
1243
|
|
|
1244 (defvar face-history nil
|
|
|
1245 "History of entered face names.")
|
|
|
1246
|
|
|
1247 (defun widget-face-action (widget &optional event)
|
|
|
1248 "Prompt for a face."
|
|
|
1249 (let ((answer (completing-read "Face: "
|
|
|
1250 (mapcar (lambda (face)
|
|
|
1251 (list (symbol-name face)))
|
|
|
1252 (face-list))
|
|
|
1253 nil nil nil
|
|
|
1254 'face-history)))
|
|
|
1255 (unless (zerop (length answer))
|
|
|
1256 (widget-value-set widget (intern answer))
|
|
|
1257 (widget-apply widget :notify widget event)
|
|
|
1258 (widget-setup))))
|
|
|
1259
|
|
|
1260 ;;; The `hook' Widget.
|
|
|
1261
|
|
|
1262 (define-widget 'hook 'list
|
|
|
1263 "A emacs lisp hook"
|
|
|
1264 :convert-widget 'custom-hook-convert-widget
|
|
|
1265 :tag "Hook")
|
|
|
1266
|
|
|
1267 (defun custom-hook-convert-widget (widget)
|
|
|
1268 ;; Handle `:custom-options'.
|
|
|
1269 (let* ((options (widget-get widget :options))
|
|
|
1270 (other `(editable-list :inline t
|
|
|
1271 :entry-format "%i %d%v"
|
|
|
1272 (function :format " %v")))
|
|
|
1273 (args (if options
|
|
|
1274 (list `(checklist :inline t
|
|
|
1275 ,@(mapcar (lambda (entry)
|
|
|
1276 `(function-item ,entry))
|
|
|
1277 options))
|
|
|
1278 other)
|
|
|
1279 (list other))))
|
|
|
1280 (widget-put widget :args args)
|
|
|
1281 widget))
|
|
|
1282
|
|
|
1283 ;;; The `custom-group' Widget.
|
|
|
1284
|
|
|
1285 (defcustom custom-group-tag-faces '(custom-group-tag-face-1)
|
|
|
1286 ;; In XEmacs, this ought to play games with font size.
|
|
|
1287 "Face used for group tags.
|
|
|
1288 The first member is used for level 1 groups, the second for level 2,
|
|
|
1289 and so forth. The remaining group tags are shown with
|
|
|
1290 `custom-group-tag-face'."
|
|
|
1291 :type '(repeat face)
|
|
|
1292 :group 'customize)
|
|
|
1293
|
|
|
1294 (defface custom-group-tag-face-1 '((((class color)
|
|
|
1295 (background dark))
|
|
|
1296 (:foreground "pink" :underline t))
|
|
|
1297 (((class color)
|
|
|
1298 (background light))
|
|
|
1299 (:foreground "red" :underline t))
|
|
|
1300 (t (:underline t)))
|
|
|
1301 "Face used for group tags.")
|
|
|
1302
|
|
|
1303 (defface custom-group-tag-face '((((class color)
|
|
|
1304 (background dark))
|
|
|
1305 (:foreground "light blue" :underline t))
|
|
|
1306 (((class color)
|
|
|
1307 (background light))
|
|
|
1308 (:foreground "blue" :underline t))
|
|
|
1309 (t (:underline t)))
|
|
|
1310 "Face used for low level group tags."
|
|
|
1311 :group 'customize)
|
|
|
1312
|
|
|
1313 (define-widget 'custom-group 'custom
|
|
|
1314 "Customize group."
|
|
|
1315 :format "%l%{%t%}:%L\n%m%h%a%v"
|
|
|
1316 :sample-face-get 'custom-group-sample-face-get
|
|
|
1317 :documentation-property 'group-documentation
|
|
|
1318 :help-echo "Push me to set or reset all members of this group."
|
|
|
1319 :value-create 'custom-group-value-create
|
|
|
1320 :action 'custom-group-action
|
|
|
1321 :custom-set 'custom-group-set
|
|
|
1322 :custom-save 'custom-group-save
|
|
|
1323 :custom-reset-current 'custom-group-reset-current
|
|
|
1324 :custom-reset-saved 'custom-group-reset-saved
|
|
|
1325 :custom-reset-factory 'custom-group-reset-factory
|
|
|
1326 :custom-menu 'custom-group-menu-create)
|
|
|
1327
|
|
|
1328 (defun custom-group-sample-face-get (widget)
|
|
|
1329 ;; Use :sample-face.
|
|
|
1330 (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces)
|
|
|
1331 'custom-group-tag-face))
|
|
|
1332
|
|
|
1333 (defun custom-group-value-create (widget)
|
|
|
1334 (let ((state (widget-get widget :custom-state)))
|
|
|
1335 (unless (eq state 'hidden)
|
|
|
1336 (custom-load-widget widget)
|
|
|
1337 (let* ((level (widget-get widget :custom-level))
|
|
|
1338 (symbol (widget-value widget))
|
|
|
1339 (members (get symbol 'custom-group))
|
|
|
1340 (prefixes (widget-get widget :custom-prefixes))
|
|
|
1341 (custom-prefix-list (custom-prefix-add symbol prefixes))
|
|
|
1342 (children (mapcar (lambda (entry)
|
|
|
1343 (widget-insert "\n")
|
|
|
1344 (prog1
|
|
|
1345 (widget-create-child-and-convert
|
|
|
1346 widget (nth 1 entry)
|
|
|
1347 :group widget
|
|
|
1348 :tag (custom-unlispify-tag-name
|
|
|
1349 (nth 0 entry))
|
|
|
1350 :custom-prefixes custom-prefix-list
|
|
|
1351 :custom-level (1+ level)
|
|
|
1352 :value (nth 0 entry))
|
|
|
1353 (unless (eq (preceding-char) ?\n)
|
|
|
1354 (widget-insert "\n"))))
|
|
|
1355 members)))
|
|
|
1356 (mapcar 'custom-magic-reset children)
|
|
|
1357 (widget-put widget :children children)
|
|
|
1358 (custom-group-state-update widget)))))
|
|
|
1359
|
|
|
1360 (defvar custom-group-menu
|
|
|
1361 '(("Set" . custom-group-set)
|
|
|
1362 ("Save" . custom-group-save)
|
|
|
1363 ("Reset to Current" . custom-group-reset-current)
|
|
|
1364 ("Reset to Saved" . custom-group-reset-saved)
|
|
|
1365 ("Reset to Factory" . custom-group-reset-factory))
|
|
|
1366 "Alist of actions for the `custom-group' widget.
|
|
|
1367 The key is a string containing the name of the action, the value is a
|
|
|
1368 lisp function taking the widget as an element which will be called
|
|
|
1369 when the action is chosen.")
|
|
|
1370
|
|
|
1371 (defun custom-group-action (widget &optional event)
|
|
|
1372 "Show the menu for `custom-group' WIDGET.
|
|
|
1373 Optional EVENT is the location for the menu."
|
|
|
1374 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
|
1375 (progn
|
|
|
1376 (widget-put widget :custom-state 'unknown)
|
|
|
1377 (custom-redraw widget))
|
|
|
1378 (let* ((completion-ignore-case t)
|
|
22
|
1379 (answer (widget-choose (capitalize
|
|
|
1380 (symbol-name (widget-get widget :value)))
|
|
18
|
1381 custom-group-menu
|
|
|
1382 event)))
|
|
|
1383 (if answer
|
|
|
1384 (funcall answer widget)))))
|
|
|
1385
|
|
|
1386 (defun custom-group-set (widget)
|
|
|
1387 "Set changes in all modified group members."
|
|
|
1388 (let ((children (widget-get widget :children)))
|
|
|
1389 (mapcar (lambda (child)
|
|
|
1390 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
1391 (widget-apply child :custom-set)))
|
|
|
1392 children )))
|
|
|
1393
|
|
|
1394 (defun custom-group-save (widget)
|
|
|
1395 "Save all modified group members."
|
|
|
1396 (let ((children (widget-get widget :children)))
|
|
|
1397 (mapcar (lambda (child)
|
|
|
1398 (when (memq (widget-get child :custom-state) '(modified set))
|
|
|
1399 (widget-apply child :custom-save)))
|
|
|
1400 children )))
|
|
|
1401
|
|
|
1402 (defun custom-group-reset-current (widget)
|
|
|
1403 "Reset all modified group members."
|
|
|
1404 (let ((children (widget-get widget :children)))
|
|
|
1405 (mapcar (lambda (child)
|
|
|
1406 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
1407 (widget-apply child :custom-reset-current)))
|
|
|
1408 children )))
|
|
|
1409
|
|
|
1410 (defun custom-group-reset-saved (widget)
|
|
|
1411 "Reset all modified or set group members."
|
|
|
1412 (let ((children (widget-get widget :children)))
|
|
|
1413 (mapcar (lambda (child)
|
|
|
1414 (when (memq (widget-get child :custom-state) '(modified set))
|
|
|
1415 (widget-apply child :custom-reset-saved)))
|
|
|
1416 children )))
|
|
|
1417
|
|
|
1418 (defun custom-group-reset-factory (widget)
|
|
|
1419 "Reset all modified, set, or saved group members."
|
|
|
1420 (let ((children (widget-get widget :children)))
|
|
|
1421 (mapcar (lambda (child)
|
|
|
1422 (when (memq (widget-get child :custom-state)
|
|
|
1423 '(modified set saved))
|
|
|
1424 (widget-apply child :custom-reset-factory)))
|
|
|
1425 children )))
|
|
|
1426
|
|
|
1427 (defun custom-group-state-update (widget)
|
|
|
1428 "Update magic."
|
|
|
1429 (unless (eq (widget-get widget :custom-state) 'hidden)
|
|
|
1430 (let* ((children (widget-get widget :children))
|
|
|
1431 (states (mapcar (lambda (child)
|
|
|
1432 (widget-get child :custom-state))
|
|
|
1433 children))
|
|
|
1434 (magics custom-magic-alist)
|
|
|
1435 (found 'factory))
|
|
|
1436 (while magics
|
|
|
1437 (let ((magic (car (car magics))))
|
|
|
1438 (if (and (not (eq magic 'hidden))
|
|
|
1439 (memq magic states))
|
|
|
1440 (setq found magic
|
|
|
1441 magics nil)
|
|
|
1442 (setq magics (cdr magics)))))
|
|
|
1443 (widget-put widget :custom-state found)))
|
|
|
1444 (custom-magic-reset widget))
|
|
|
1445
|
|
|
1446 ;;; The `custom-save-all' Function.
|
|
|
1447
|
|
|
1448 (defcustom custom-file "~/.emacs"
|
|
|
1449 "File used for storing customization information.
|
|
|
1450 If you change this from the default \"~/.emacs\" you need to
|
|
|
1451 explicitly load that file for the settings to take effect."
|
|
|
1452 :type 'file
|
|
|
1453 :group 'customize)
|
|
|
1454
|
|
|
1455 (defun custom-save-delete (symbol)
|
|
|
1456 "Delete the call to SYMBOL form `custom-file'.
|
|
|
1457 Leave point at the location of the call, or after the last expression."
|
|
|
1458 (set-buffer (find-file-noselect custom-file))
|
|
|
1459 (goto-char (point-min))
|
|
|
1460 (catch 'found
|
|
|
1461 (while t
|
|
|
1462 (let ((sexp (condition-case nil
|
|
|
1463 (read (current-buffer))
|
|
|
1464 (end-of-file (throw 'found nil)))))
|
|
|
1465 (when (and (listp sexp)
|
|
|
1466 (eq (car sexp) symbol))
|
|
|
1467 (delete-region (save-excursion
|
|
|
1468 (backward-sexp)
|
|
|
1469 (point))
|
|
|
1470 (point))
|
|
|
1471 (throw 'found nil))))))
|
|
|
1472
|
|
|
1473 (defun custom-save-variables ()
|
|
|
1474 "Save all customized variables in `custom-file'."
|
|
|
1475 (save-excursion
|
|
|
1476 (custom-save-delete 'custom-set-variables)
|
|
|
1477 (let ((standard-output (current-buffer)))
|
|
|
1478 (unless (bolp)
|
|
|
1479 (princ "\n"))
|
|
|
1480 (princ "(custom-set-variables")
|
|
|
1481 (mapatoms (lambda (symbol)
|
|
|
1482 (let ((value (get symbol 'saved-value)))
|
|
|
1483 (when value
|
|
|
1484 (princ "\n '(")
|
|
|
1485 (princ symbol)
|
|
|
1486 (princ " ")
|
|
|
1487 (prin1 (car value))
|
|
|
1488 (if (or (get symbol 'factory-value)
|
|
|
1489 (and (not (boundp symbol))
|
|
|
1490 (not (get symbol 'force-value))))
|
|
|
1491 (princ ")")
|
|
|
1492 (princ " t)"))))))
|
|
|
1493 (princ ")")
|
|
|
1494 (unless (eolp)
|
|
|
1495 (princ "\n")))))
|
|
|
1496
|
|
|
1497 (defun custom-save-faces ()
|
|
|
1498 "Save all customized faces in `custom-file'."
|
|
|
1499 (save-excursion
|
|
|
1500 (custom-save-delete 'custom-set-faces)
|
|
|
1501 (let ((standard-output (current-buffer)))
|
|
|
1502 (unless (bolp)
|
|
|
1503 (princ "\n"))
|
|
|
1504 (princ "(custom-set-faces")
|
|
|
1505 (mapatoms (lambda (symbol)
|
|
|
1506 (let ((value (get symbol 'saved-face)))
|
|
|
1507 (when value
|
|
|
1508 (princ "\n '(")
|
|
|
1509 (princ symbol)
|
|
|
1510 (princ " ")
|
|
|
1511 (prin1 value)
|
|
|
1512 (if (or (get symbol 'factory-face)
|
|
|
1513 (and (not (custom-facep symbol))
|
|
|
1514 (not (get symbol 'force-face))))
|
|
|
1515 (princ ")")
|
|
|
1516 (princ " t)"))))))
|
|
|
1517 (princ ")")
|
|
|
1518 (unless (eolp)
|
|
|
1519 (princ "\n")))))
|
|
|
1520
|
|
|
1521 (defun custom-save-all ()
|
|
|
1522 "Save all customizations in `custom-file'."
|
|
|
1523 (custom-save-variables)
|
|
|
1524 (custom-save-faces)
|
|
|
1525 (save-excursion
|
|
|
1526 (set-buffer (find-file-noselect custom-file))
|
|
|
1527 (save-buffer)))
|
|
|
1528
|
|
|
1529 ;;; The Customize Menu.
|
|
|
1530
|
|
|
1531 (defcustom custom-menu-nesting 2
|
|
|
1532 "Maximum nesting in custom menus."
|
|
|
1533 :type 'integer
|
|
|
1534 :group 'customize)
|
|
|
1535
|
|
|
1536 (defun custom-face-menu-create (widget symbol)
|
|
|
1537 "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
|
|
|
1538 (vector (custom-unlispify-menu-entry symbol)
|
|
|
1539 `(custom-buffer-create '((,symbol custom-face)))
|
|
|
1540 t))
|
|
|
1541
|
|
|
1542 (defun custom-variable-menu-create (widget symbol)
|
|
|
1543 "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
|
|
|
1544 (let ((type (get symbol 'custom-type)))
|
|
|
1545 (unless (listp type)
|
|
|
1546 (setq type (list type)))
|
|
|
1547 (if (and type (widget-get type :custom-menu))
|
|
|
1548 (widget-apply type :custom-menu symbol)
|
|
|
1549 (vector (custom-unlispify-menu-entry symbol)
|
|
|
1550 `(custom-buffer-create '((,symbol custom-variable)))
|
|
|
1551 t))))
|
|
|
1552
|
|
|
1553 (widget-put (get 'boolean 'widget-type)
|
|
|
1554 :custom-menu (lambda (widget symbol)
|
|
|
1555 (vector (custom-unlispify-menu-entry symbol)
|
|
|
1556 `(custom-buffer-create
|
|
|
1557 '((,symbol custom-variable)))
|
|
|
1558 ':style 'toggle
|
|
|
1559 ':selected symbol)))
|
|
|
1560
|
|
|
1561 (defun custom-group-menu-create (widget symbol)
|
|
|
1562 "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
|
|
|
1563 (custom-menu-create symbol))
|
|
|
1564
|
|
|
1565 (defun custom-menu-create (symbol &optional name)
|
|
|
1566 "Create menu for customization group SYMBOL.
|
|
|
1567 If optional NAME is given, use that as the name of the menu.
|
|
|
1568 Otherwise make up a name from SYMBOL.
|
|
|
1569 The menu is in a format applicable to `easy-menu-define'."
|
|
|
1570 (unless name
|
|
|
1571 (setq name (custom-unlispify-menu-entry symbol)))
|
|
|
1572 (let ((item (vector name
|
|
|
1573 `(custom-buffer-create '((,symbol custom-group)))
|
|
|
1574 t)))
|
|
|
1575 (if (and (> custom-menu-nesting 0)
|
|
|
1576 (< (length (get symbol 'custom-group)) widget-menu-max-size))
|
|
|
1577 (let ((custom-menu-nesting (1- custom-menu-nesting))
|
|
|
1578 (custom-prefix-list (custom-prefix-add symbol
|
|
|
1579 custom-prefix-list)))
|
|
|
1580 (custom-load-symbol symbol)
|
|
|
1581 `(,(custom-unlispify-menu-entry symbol t)
|
|
|
1582 ,item
|
|
|
1583 "--"
|
|
|
1584 ,@(mapcar (lambda (entry)
|
|
|
1585 (widget-apply (if (listp (nth 1 entry))
|
|
|
1586 (nth 1 entry)
|
|
|
1587 (list (nth 1 entry)))
|
|
|
1588 :custom-menu (nth 0 entry)))
|
|
|
1589 (get symbol 'custom-group))))
|
|
|
1590 item)))
|
|
|
1591
|
|
|
1592 ;;;###autoload
|
|
|
1593 (defun custom-menu-update ()
|
|
|
1594 "Update customize menu."
|
|
|
1595 (interactive)
|
|
|
1596 (add-hook 'custom-define-hook 'custom-menu-reset)
|
|
|
1597 (let ((menu `(,(car custom-help-menu)
|
|
|
1598 ,(widget-apply '(custom-group) :custom-menu 'emacs)
|
|
|
1599 ,@(cdr (cdr custom-help-menu)))))
|
|
|
1600 (if (fboundp 'add-submenu)
|
|
|
1601 (add-submenu '("Help") menu)
|
|
|
1602 (define-key global-map [menu-bar help-menu customize-menu]
|
|
|
1603 (cons (car menu) (easy-menu-create-keymaps (car menu) (cdr menu)))))))
|
|
|
1604
|
|
|
1605 ;;; Dependencies.
|
|
|
1606
|
|
|
1607 ;;;###autoload
|
|
|
1608 (defun custom-make-dependencies ()
|
|
|
1609 "Batch function to extract custom dependencies from .el files.
|
|
|
1610 Usage: emacs -batch *.el -f custom-make-dependencies > deps.el"
|
|
|
1611 (let ((buffers (buffer-list)))
|
|
|
1612 (while buffers
|
|
|
1613 (set-buffer (car buffers))
|
|
|
1614 (setq buffers (cdr buffers))
|
|
|
1615 (let ((file (buffer-file-name)))
|
|
|
1616 (when (and file (string-match "\\`\\(.*\\)\\.el\\'" file))
|
|
|
1617 (goto-char (point-min))
|
|
|
1618 (condition-case nil
|
|
|
1619 (let ((name (file-name-nondirectory (match-string 1 file))))
|
|
|
1620 (while t
|
|
|
1621 (let ((expr (read (current-buffer))))
|
|
|
1622 (when (and (listp expr)
|
|
|
1623 (memq (car expr) '(defcustom defface defgroup)))
|
|
|
1624 (eval expr)
|
|
|
1625 (put (nth 1 expr) 'custom-where name)))))
|
|
|
1626 (error nil))))))
|
|
|
1627 (mapatoms (lambda (symbol)
|
|
|
1628 (let ((members (get symbol 'custom-group))
|
|
|
1629 item where found)
|
|
|
1630 (when members
|
|
|
1631 (princ "(put '")
|
|
|
1632 (princ symbol)
|
|
|
1633 (princ " 'custom-loads '(")
|
|
|
1634 (while members
|
|
|
1635 (setq item (car (car members))
|
|
|
1636 members (cdr members)
|
|
|
1637 where (get item 'custom-where))
|
|
|
1638 (unless (or (null where)
|
|
|
1639 (member where found))
|
|
|
1640 (when found
|
|
|
1641 (princ " "))
|
|
|
1642 (prin1 where)
|
|
|
1643 (push where found)))
|
|
|
1644 (princ "))\n"))))))
|
|
|
1645
|
|
|
1646 ;;; The End.
|
|
|
1647
|
|
|
1648 (provide 'custom-edit)
|
|
|
1649
|
|
|
1650 ;; custom-edit.el ends here
|
