|
428
|
1 ;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages.
|
|
|
2 ;;
|
|
4178
|
3 ;; Copyright (C) 2007 Didier Verna
|
|
|
4 ;; Copyright (C) 2003 Ben Wing
|
|
438
|
5 ;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc.
|
|
428
|
6 ;;
|
|
|
7 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
|
|
4178
|
8 ;; Maintainer: Didier Verna <didier@xemacs.org>
|
|
428
|
9 ;; Keywords: help, faces
|
|
|
10 ;; Version: 1.9960-x
|
|
|
11 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
|
|
|
12
|
|
|
13 ;; This file is part of XEmacs.
|
|
|
14
|
|
|
15 ;; XEmacs is free software; you can redistribute it and/or modify
|
|
|
16 ;; it under the terms of the GNU General Public License as published by
|
|
|
17 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
18 ;; any later version.
|
|
|
19
|
|
|
20 ;; XEmacs is distributed in the hope that it will be useful,
|
|
|
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
23 ;; GNU General Public License for more details.
|
|
|
24
|
|
|
25 ;; You should have received a copy of the GNU General Public License
|
|
|
26 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
28 ;; Boston, MA 02111-1307, USA.
|
|
|
29
|
|
|
30 ;;; Commentary:
|
|
|
31 ;;
|
|
|
32 ;; This file implements the code to create and edit customize buffers.
|
|
|
33 ;;
|
|
|
34 ;; See `custom.el'.
|
|
|
35
|
|
|
36 ;; No commands should have names starting with `custom-' because
|
|
|
37 ;; that interferes with completion. Use `customize-' for commands
|
|
|
38 ;; that the user will run with M-x, and `Custom-' for interactive commands.
|
|
|
39
|
|
|
40 ;; NOTE: In many places within this file we use `mapatoms', which is
|
|
|
41 ;; very slow in an average XEmacs because of the large number of
|
|
|
42 ;; symbols requiring a large number of funcalls -- XEmacs with Gnus
|
|
|
43 ;; can grow to some 17000 symbols without ever doing anything fancy.
|
|
|
44 ;; It would probably pay off to make a hash table of symbols known to
|
|
|
45 ;; Custom, similar to custom-group-hash-table.
|
|
|
46
|
|
|
47 ;; This is not top priority, because none of the functions that do
|
|
|
48 ;; mapatoms are speed-critical (the one that was now uses
|
|
|
49 ;; custom-group-hash-table), but it would be nice to have.
|
|
|
50
|
|
|
51
|
|
|
52 ;;; Code:
|
|
|
53
|
|
|
54 (require 'cus-face)
|
|
|
55 (require 'wid-edit)
|
|
|
56 (require 'easymenu)
|
|
|
57
|
|
|
58 (require 'cus-load)
|
|
|
59 (require 'cus-start)
|
|
442
|
60 (require 'cus-file)
|
|
428
|
61
|
|
|
62 ;; Huh? This looks dirty!
|
|
|
63 (put 'custom-define-hook 'custom-type 'hook)
|
|
|
64 (put 'custom-define-hook 'standard-value '(nil))
|
|
|
65 (custom-add-to-group 'customize 'custom-define-hook 'custom-variable)
|
|
|
66
|
|
|
67 ;;; Customization Groups.
|
|
|
68
|
|
|
69 (defgroup emacs nil
|
|
|
70 "Customization of the One True Editor."
|
|
|
71 :link '(custom-manual "(XEmacs)Top"))
|
|
|
72
|
|
|
73 ;; Most of these groups are stolen from `finder.el',
|
|
|
74 (defgroup editing nil
|
|
|
75 "Basic text editing facilities."
|
|
|
76 :group 'emacs)
|
|
|
77
|
|
|
78 (defgroup matching nil
|
|
|
79 "Various sorts of searching and matching."
|
|
|
80 :group 'editing)
|
|
|
81
|
|
|
82 (defgroup emulations nil
|
|
|
83 "Emulations of other editors."
|
|
|
84 :group 'editing)
|
|
|
85
|
|
|
86 (defgroup outlines nil
|
|
|
87 "Support for hierarchical outlining."
|
|
|
88 :group 'editing)
|
|
|
89
|
|
|
90 (defgroup external nil
|
|
|
91 "Interfacing to external utilities."
|
|
|
92 :group 'emacs)
|
|
|
93
|
|
|
94 (defgroup bib nil
|
|
|
95 "Code related to the `bib' bibliography processor."
|
|
|
96 :tag "Bibliography"
|
|
|
97 :group 'external)
|
|
|
98
|
|
|
99 (defgroup programming nil
|
|
|
100 "Support for programming in other languages."
|
|
|
101 :group 'emacs)
|
|
|
102
|
|
|
103 (defgroup languages nil
|
|
|
104 "Specialized modes for editing programming languages."
|
|
|
105 :group 'programming)
|
|
|
106
|
|
|
107 ;; #### This should be in cc-vars.el
|
|
|
108 (defgroup c nil
|
|
|
109 "Support for the C language and related languages."
|
|
|
110 :group 'languages)
|
|
|
111
|
|
|
112 (defgroup tools nil
|
|
|
113 "Programming tools."
|
|
|
114 :group 'programming)
|
|
|
115
|
|
|
116 (defgroup oop nil
|
|
|
117 "Support for object-oriented programming."
|
|
|
118 :group 'programming)
|
|
|
119
|
|
|
120 (defgroup applications nil
|
|
|
121 "Applications written in Emacs."
|
|
|
122 :group 'emacs)
|
|
|
123
|
|
|
124 ;; #### This should be in calendar.el
|
|
|
125 (defgroup calendar nil
|
|
|
126 "Calendar and time management support."
|
|
|
127 :group 'applications)
|
|
|
128
|
|
|
129 (defgroup mail nil
|
|
|
130 "Modes for electronic-mail handling."
|
|
|
131 :group 'applications)
|
|
|
132
|
|
|
133 (defgroup news nil
|
|
|
134 "Support for netnews reading and posting."
|
|
|
135 :group 'applications)
|
|
|
136
|
|
|
137 (defgroup games nil
|
|
|
138 "Games, jokes and amusements."
|
|
|
139 :group 'applications)
|
|
|
140
|
|
|
141 (defgroup development nil
|
|
|
142 "Support for further development of Emacs."
|
|
|
143 :group 'emacs)
|
|
|
144
|
|
|
145 (defgroup docs nil
|
|
|
146 "Support for Emacs documentation."
|
|
|
147 :group 'development)
|
|
|
148
|
|
|
149 (defgroup extensions nil
|
|
|
150 "Emacs Lisp language extensions."
|
|
|
151 :group 'development)
|
|
|
152
|
|
|
153 (defgroup internal nil
|
|
|
154 "Code for Emacs internals, build process, defaults."
|
|
|
155 :group 'development)
|
|
|
156
|
|
|
157 (defgroup maint nil
|
|
|
158 "Maintenance aids for the Emacs development group."
|
|
|
159 :tag "Maintenance"
|
|
|
160 :group 'development)
|
|
|
161
|
|
|
162 (defgroup environment nil
|
|
|
163 "Fitting Emacs with its environment."
|
|
|
164 :group 'emacs)
|
|
|
165
|
|
|
166 (defgroup comm nil
|
|
|
167 "Communications, networking, remote access to files."
|
|
|
168 :tag "Communication"
|
|
|
169 :group 'environment)
|
|
|
170
|
|
|
171 (defgroup hardware nil
|
|
|
172 "Support for interfacing with exotic hardware."
|
|
|
173 :group 'environment)
|
|
|
174
|
|
|
175 (defgroup terminals nil
|
|
|
176 "Support for terminal types."
|
|
|
177 :group 'environment)
|
|
|
178
|
|
|
179 (defgroup unix nil
|
|
|
180 "Front-ends/assistants for, or emulators of, UNIX features."
|
|
|
181 :group 'environment)
|
|
|
182
|
|
|
183 (defgroup i18n nil
|
|
|
184 "Internationalization and alternate character-set support."
|
|
|
185 :group 'environment
|
|
|
186 :group 'editing)
|
|
|
187
|
|
|
188 (defgroup data nil
|
|
|
189 "Support editing files of data."
|
|
|
190 :group 'emacs)
|
|
|
191
|
|
|
192 (defgroup wp nil
|
|
|
193 "Word processing."
|
|
|
194 :group 'emacs)
|
|
|
195
|
|
|
196 (defgroup tex nil
|
|
|
197 "Code related to the TeX formatter."
|
|
|
198 :group 'wp)
|
|
|
199
|
|
|
200 (defgroup hypermedia nil
|
|
|
201 "Support for links between text or other media types."
|
|
|
202 :group 'emacs)
|
|
|
203
|
|
|
204 (defgroup local nil
|
|
|
205 "Code local to your site."
|
|
|
206 :group 'emacs)
|
|
|
207
|
|
|
208 (defgroup customize '((widgets custom-group))
|
|
|
209 "Customization of the Customization support."
|
|
|
210 :link '(custom-manual "(custom)Top")
|
|
|
211 :link '(url-link :tag "Development Page"
|
|
|
212 "http://www.dina.kvl.dk/~abraham/custom/")
|
|
|
213 :prefix "custom-"
|
|
|
214 :group 'help)
|
|
|
215
|
|
|
216 (defgroup custom-faces nil
|
|
|
217 "Faces used by customize."
|
|
|
218 :group 'customize
|
|
|
219 :group 'faces)
|
|
|
220
|
|
|
221 (defgroup custom-browse nil
|
|
|
222 "Control customize browser."
|
|
|
223 :prefix "custom-"
|
|
|
224 :group 'customize)
|
|
|
225
|
|
|
226 (defgroup custom-buffer nil
|
|
|
227 "Control customize buffers."
|
|
|
228 :prefix "custom-"
|
|
|
229 :group 'customize)
|
|
|
230
|
|
|
231 (defgroup custom-menu nil
|
|
|
232 "Control customize menus."
|
|
|
233 :prefix "custom-"
|
|
|
234 :group 'customize)
|
|
|
235
|
|
|
236 (defgroup alloc nil
|
|
613
|
237 "Storage allocation and gc for XEmacs Lisp interpreter."
|
|
428
|
238 :tag "Storage Allocation"
|
|
|
239 :group 'internal)
|
|
|
240
|
|
|
241 (defgroup undo nil
|
|
|
242 "Undoing changes in buffers."
|
|
|
243 :group 'editing)
|
|
|
244
|
|
|
245 (defgroup editing-basics nil
|
|
|
246 "Most basic editing facilities."
|
|
|
247 :group 'editing)
|
|
|
248
|
|
|
249 (defgroup display nil
|
|
|
250 "How characters are displayed in buffers."
|
|
|
251 :group 'environment)
|
|
|
252
|
|
|
253 (defgroup installation nil
|
|
|
254 "The Emacs installation."
|
|
|
255 :group 'environment)
|
|
|
256
|
|
|
257 (defgroup limits nil
|
|
|
258 "Internal Emacs limits."
|
|
|
259 :group 'internal)
|
|
|
260
|
|
|
261 (defgroup debug nil
|
|
|
262 "Debugging Emacs itself."
|
|
|
263 :group 'development)
|
|
|
264
|
|
|
265 (defgroup mule nil
|
|
|
266 "Mule XEmacs internationalization."
|
|
|
267 :group 'i18n)
|
|
|
268
|
|
|
269
|
|
|
270 ;;; Utilities.
|
|
|
271
|
|
|
272 (defun custom-quote (sexp)
|
|
|
273 "Quote SEXP iff it is not self quoting."
|
|
|
274 (if (or (memq sexp '(t nil))
|
|
|
275 (keywordp sexp)
|
|
|
276 (eq (car-safe sexp) 'lambda)
|
|
|
277 (stringp sexp)
|
|
|
278 (numberp sexp)
|
|
|
279 (characterp sexp)
|
|
|
280 (vectorp sexp)
|
|
|
281 (bit-vector-p sexp))
|
|
|
282 sexp
|
|
|
283 (list 'quote sexp)))
|
|
|
284
|
|
|
285 (defun custom-split-regexp-maybe (regexp)
|
|
|
286 "If REGEXP is a string, split it to a list at `\\|'.
|
|
|
287 You can get the original back with from the result with:
|
|
|
288 (mapconcat #'identity result \"\\|\")
|
|
|
289
|
|
|
290 IF REGEXP is not a string, return it unchanged."
|
|
|
291 (if (stringp regexp)
|
|
|
292 (split-string regexp "\\\\|")
|
|
|
293 regexp))
|
|
|
294
|
|
|
295 (defun custom-variable-prompt ()
|
|
|
296 ;; Code stolen from `help.el'.
|
|
|
297 "Prompt for a variable, defaulting to the variable at point.
|
|
|
298 Return a list suitable for use in `interactive'."
|
|
|
299 (let ((v (variable-at-point))
|
|
|
300 (enable-recursive-minibuffers t)
|
|
|
301 val)
|
|
|
302 (setq val (completing-read
|
|
|
303 (if (symbolp v)
|
|
|
304 (format "Customize variable: (default %s) " v)
|
|
|
305 "Customize variable: ")
|
|
|
306 obarray (lambda (symbol)
|
|
|
307 (and (boundp symbol)
|
|
|
308 (or (get symbol 'custom-type)
|
|
476
|
309 (user-variable-p symbol))))
|
|
4178
|
310 t nil nil (and v (symbol-name v))))
|
|
428
|
311 (list (if (equal val "")
|
|
|
312 (if (symbolp v) v nil)
|
|
|
313 (intern val)))))
|
|
|
314
|
|
|
315 ;; Here we take not only the actual groups, but the loads, too.
|
|
|
316 (defun custom-group-prompt (prompt)
|
|
|
317 "Read group from minibuffer."
|
|
|
318 (let ((completion-ignore-case t))
|
|
|
319 (list (completing-read
|
|
|
320 prompt obarray
|
|
|
321 (lambda (symbol)
|
|
|
322 (or (get symbol 'custom-group)
|
|
|
323 (get symbol 'custom-loads)))
|
|
|
324 t))))
|
|
|
325
|
|
|
326 (defun custom-menu-filter (menu widget)
|
|
|
327 "Convert MENU to the form used by `widget-choose'.
|
|
|
328 MENU should be in the same format as `custom-variable-menu'.
|
|
|
329 WIDGET is the widget to apply the filter entries of MENU on."
|
|
|
330 (let ((result nil)
|
|
|
331 current name action filter)
|
|
|
332 (while menu
|
|
|
333 (setq current (car menu)
|
|
|
334 name (nth 0 current)
|
|
|
335 action (nth 1 current)
|
|
|
336 filter (nth 2 current)
|
|
|
337 menu (cdr menu))
|
|
|
338 (if (or (null filter) (funcall filter widget))
|
|
|
339 (push (cons name action) result)
|
|
|
340 (push name result)))
|
|
|
341 (nreverse result)))
|
|
|
342
|
|
|
343
|
|
|
344 ;;; Unlispify.
|
|
|
345
|
|
|
346 (defvar custom-prefix-list nil
|
|
|
347 "List of prefixes that should be ignored by `custom-unlispify'")
|
|
|
348
|
|
848
|
349 (defcustom custom-save-pretty-print t
|
|
|
350 "Non-nil means pretty-print values of customized variables if available."
|
|
|
351 :group 'customize
|
|
|
352 :type 'boolean)
|
|
|
353
|
|
|
354
|
|
428
|
355 (defcustom custom-unlispify-menu-entries t
|
|
|
356 "Display menu entries as words instead of symbols if non nil."
|
|
|
357 :group 'custom-menu
|
|
|
358 :type 'boolean)
|
|
|
359
|
|
|
360 (defcustom custom-unlispify-remove-prefixes t
|
|
|
361 "Non-nil means remove group prefixes from option names in buffers and menus.
|
|
|
362 This only has an effect when `custom-unlispify-tag-names' or
|
|
|
363 `custom-unlispify-menu-entries' is on."
|
|
|
364 :group 'custom-menu
|
|
|
365 :type 'boolean)
|
|
|
366
|
|
|
367 (defun custom-unlispify-menu-entry (symbol &optional no-suffix)
|
|
|
368 "Convert symbol into a menu entry."
|
|
|
369 (cond ((not custom-unlispify-menu-entries)
|
|
|
370 (symbol-name symbol))
|
|
|
371 ((get symbol 'custom-tag)
|
|
|
372 (if no-suffix
|
|
|
373 (get symbol 'custom-tag)
|
|
|
374 (concat (get symbol 'custom-tag) "...")))
|
|
|
375 (t
|
|
|
376 (with-current-buffer (get-buffer-create " *Custom-Work*")
|
|
|
377 (erase-buffer)
|
|
|
378 (princ symbol (current-buffer))
|
|
|
379 (goto-char (point-min))
|
|
|
380 (when (and (eq (get symbol 'custom-type) 'boolean)
|
|
|
381 (re-search-forward "-p\\'" nil t))
|
|
|
382 (replace-match "" t t)
|
|
|
383 (goto-char (point-min)))
|
|
|
384 (when custom-unlispify-remove-prefixes
|
|
|
385 (let ((prefixes custom-prefix-list)
|
|
|
386 prefix)
|
|
|
387 (while prefixes
|
|
|
388 (setq prefix (car prefixes))
|
|
|
389 (if (search-forward prefix (+ (point) (length prefix)) t)
|
|
|
390 (progn
|
|
|
391 (setq prefixes nil)
|
|
|
392 (delete-region (point-min) (point)))
|
|
|
393 (setq prefixes (cdr prefixes))))))
|
|
|
394 (subst-char-in-region (point-min) (point-max) ?- ?\ t)
|
|
|
395 (capitalize-region (point-min) (point-max))
|
|
|
396 (unless no-suffix
|
|
|
397 (goto-char (point-max))
|
|
|
398 (insert "..."))
|
|
|
399 (buffer-string)))))
|
|
|
400
|
|
|
401 (defcustom custom-unlispify-tag-names t
|
|
|
402 "Display tag names as words instead of symbols if non nil."
|
|
|
403 :group 'custom-buffer
|
|
|
404 :type 'boolean)
|
|
|
405
|
|
|
406 (defun custom-unlispify-tag-name (symbol)
|
|
|
407 "Convert symbol into a menu entry."
|
|
|
408 (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
|
|
|
409 (custom-unlispify-menu-entry symbol t)))
|
|
|
410
|
|
|
411 (defun custom-prefix-add (symbol prefixes)
|
|
440
|
412 ;; Add SYMBOL to list of ignored PREFIXES.
|
|
428
|
413 (cons (or (get symbol 'custom-prefix)
|
|
|
414 (concat (symbol-name symbol) "-"))
|
|
|
415 prefixes))
|
|
|
416
|
|
|
417
|
|
|
418 ;;; Guess.
|
|
|
419
|
|
|
420 (defcustom custom-guess-name-alist
|
|
|
421 '(("-p\\'" boolean)
|
|
|
422 ("-hooks?\\'" hook)
|
|
|
423 ("-face\\'" face)
|
|
|
424 ("-file\\'" file)
|
|
|
425 ("-function\\'" function)
|
|
|
426 ("-functions\\'" (repeat function))
|
|
|
427 ("-list\\'" (repeat sexp))
|
|
|
428 ("-alist\\'" (repeat (cons sexp sexp))))
|
|
|
429 "Alist of (MATCH TYPE).
|
|
|
430
|
|
|
431 MATCH should be a regexp matching the name of a symbol, and TYPE should
|
|
|
432 be a widget suitable for editing the value of that symbol. The TYPE
|
|
|
433 of the first entry where MATCH matches the name of the symbol will be
|
|
|
434 used.
|
|
|
435
|
|
|
436 This is used for guessing the type of variables not declared with
|
|
|
437 customize."
|
|
|
438 :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
|
|
|
439 :group 'customize)
|
|
|
440
|
|
|
441 (defcustom custom-guess-doc-alist
|
|
|
442 '(("\\`\\*?Non-nil " boolean))
|
|
|
443 "Alist of (MATCH TYPE).
|
|
|
444
|
|
|
445 MATCH should be a regexp matching a documentation string, and TYPE
|
|
|
446 should be a widget suitable for editing the value of a variable with
|
|
|
447 that documentation string. The TYPE of the first entry where MATCH
|
|
|
448 matches the name of the symbol will be used.
|
|
|
449
|
|
|
450 This is used for guessing the type of variables not declared with
|
|
|
451 customize."
|
|
|
452 :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
|
|
|
453 :group 'customize)
|
|
|
454
|
|
|
455 (defun custom-guess-type (symbol)
|
|
|
456 "Guess a widget suitable for editing the value of SYMBOL.
|
|
|
457 This is done by matching SYMBOL with `custom-guess-name-alist' and
|
|
|
458 if that fails, the doc string with `custom-guess-doc-alist'."
|
|
|
459 (let ((name (symbol-name symbol))
|
|
|
460 (names custom-guess-name-alist)
|
|
|
461 current found)
|
|
|
462 (while names
|
|
|
463 (setq current (car names)
|
|
|
464 names (cdr names))
|
|
|
465 (when (string-match (nth 0 current) name)
|
|
|
466 (setq found (nth 1 current)
|
|
|
467 names nil)))
|
|
|
468 (unless found
|
|
|
469 (let ((doc (documentation-property symbol 'variable-documentation))
|
|
|
470 (docs custom-guess-doc-alist))
|
|
|
471 (when doc
|
|
|
472 (while docs
|
|
|
473 (setq current (car docs)
|
|
|
474 docs (cdr docs))
|
|
|
475 (when (string-match (nth 0 current) doc)
|
|
|
476 (setq found (nth 1 current)
|
|
|
477 docs nil))))))
|
|
|
478 found))
|
|
|
479
|
|
|
480
|
|
|
481 ;;; Sorting.
|
|
|
482
|
|
|
483 (defcustom custom-browse-sort-alphabetically nil
|
|
|
484 "If non-nil, sort members of each customization group alphabetically."
|
|
|
485 :type 'boolean
|
|
|
486 :group 'custom-browse)
|
|
|
487
|
|
|
488 (defcustom custom-browse-order-groups nil
|
|
|
489 "If non-nil, order group members within each customization group.
|
|
|
490 If `first', order groups before non-groups.
|
|
|
491 If `last', order groups after non-groups."
|
|
|
492 :type '(choice (const first)
|
|
|
493 (const last)
|
|
|
494 (const :tag "none" nil))
|
|
|
495 :group 'custom-browse)
|
|
|
496
|
|
|
497 (defcustom custom-browse-only-groups nil
|
|
|
498 "If non-nil, show group members only within each customization group."
|
|
|
499 :type 'boolean
|
|
|
500 :group 'custom-browse)
|
|
|
501
|
|
|
502 (defcustom custom-buffer-sort-alphabetically nil
|
|
|
503 "If non-nil, sort members of each customization group alphabetically."
|
|
|
504 :type 'boolean
|
|
|
505 :group 'custom-buffer)
|
|
|
506
|
|
|
507 (defcustom custom-buffer-order-groups 'last
|
|
|
508 "If non-nil, order group members within each customization group.
|
|
|
509 If `first', order groups before non-groups.
|
|
|
510 If `last', order groups after non-groups."
|
|
|
511 :type '(choice (const first)
|
|
|
512 (const last)
|
|
|
513 (const :tag "none" nil))
|
|
|
514 :group 'custom-buffer)
|
|
|
515
|
|
|
516 (defcustom custom-menu-sort-alphabetically nil
|
|
|
517 "If non-nil, sort members of each customization group alphabetically."
|
|
|
518 :type 'boolean
|
|
|
519 :group 'custom-menu)
|
|
|
520
|
|
|
521 (defcustom custom-menu-order-groups 'first
|
|
|
522 "If non-nil, order group members within each customization group.
|
|
|
523 If `first', order groups before non-groups.
|
|
|
524 If `last', order groups after non-groups."
|
|
|
525 :type '(choice (const first)
|
|
|
526 (const last)
|
|
|
527 (const :tag "none" nil))
|
|
|
528 :group 'custom-menu)
|
|
|
529
|
|
|
530 (defun custom-sort-items (items sort-alphabetically order-groups)
|
|
|
531 "Return a sorted copy of ITEMS.
|
|
|
532 ITEMS should be a `custom-group' property.
|
|
|
533 If SORT-ALPHABETICALLY non-nil, sort alphabetically.
|
|
|
534 If ORDER-GROUPS is `first' order groups before non-groups, if `last' order
|
|
|
535 groups after non-groups, if nil do not order groups at all."
|
|
|
536 (sort (copy-sequence items)
|
|
|
537 (lambda (a b)
|
|
|
538 (let ((typea (nth 1 a)) (typeb (nth 1 b))
|
|
|
539 (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b))))
|
|
|
540 (cond ((not order-groups)
|
|
|
541 ;; Since we don't care about A and B order, maybe sort.
|
|
|
542 (when sort-alphabetically
|
|
|
543 (string-lessp namea nameb)))
|
|
|
544 ((eq typea 'custom-group)
|
|
|
545 ;; If B is also a group, maybe sort. Otherwise, order A and B.
|
|
|
546 (if (eq typeb 'custom-group)
|
|
|
547 (when sort-alphabetically
|
|
|
548 (string-lessp namea nameb))
|
|
|
549 (eq order-groups 'first)))
|
|
|
550 ((eq typeb 'custom-group)
|
|
|
551 ;; Since A cannot be a group, order A and B.
|
|
|
552 (eq order-groups 'last))
|
|
|
553 (sort-alphabetically
|
|
|
554 ;; Since A and B cannot be groups, sort.
|
|
|
555 (string-lessp namea nameb)))))))
|
|
|
556
|
|
|
557
|
|
|
558 ;;; Custom Mode Commands.
|
|
|
559
|
|
|
560 (defvar custom-options nil
|
|
|
561 "Customization widgets in the current buffer.")
|
|
|
562
|
|
|
563 (defun Custom-set ()
|
|
|
564 "Set changes in all modified options."
|
|
|
565 (interactive)
|
|
|
566 (let ((children custom-options))
|
|
|
567 (mapc (lambda (child)
|
|
|
568 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
569 (widget-apply child :custom-set)))
|
|
|
570 children)))
|
|
|
571
|
|
|
572 (defun Custom-save ()
|
|
480
|
573 "Set all modified options and save them."
|
|
428
|
574 (interactive)
|
|
480
|
575 (let ((all-children custom-options)
|
|
|
576 children)
|
|
428
|
577 (mapc (lambda (child)
|
|
|
578 (when (memq (widget-get child :custom-state) '(modified set))
|
|
480
|
579 (push child children)))
|
|
|
580 all-children)
|
|
|
581 (let ((the-children children)
|
|
|
582 child)
|
|
|
583 (while (setq child (pop the-children))
|
|
|
584 (widget-apply child :custom-pre-save)))
|
|
|
585 (custom-save-all)
|
|
|
586 (let ((the-children children)
|
|
|
587 child)
|
|
|
588 (while (setq child (pop the-children))
|
|
|
589 (widget-apply child :custom-post-save)))
|
|
|
590 ))
|
|
428
|
591
|
|
|
592 (defvar custom-reset-menu
|
|
|
593 '(("Current" . Custom-reset-current)
|
|
|
594 ("Saved" . Custom-reset-saved)
|
|
|
595 ("Standard Settings" . Custom-reset-standard))
|
|
|
596 "Alist of actions for the `Reset' button.
|
|
|
597 The key is a string containing the name of the action, the value is a
|
|
|
598 lisp function taking the widget as an element which will be called
|
|
|
599 when the action is chosen.")
|
|
|
600
|
|
|
601 (defun custom-reset (event)
|
|
|
602 "Select item from reset menu."
|
|
|
603 (let* ((completion-ignore-case t)
|
|
|
604 (answer (widget-choose "Reset to"
|
|
|
605 custom-reset-menu
|
|
|
606 event)))
|
|
|
607 (if answer
|
|
|
608 (funcall answer))))
|
|
|
609
|
|
|
610 (defun Custom-reset-current (&rest ignore)
|
|
|
611 "Reset all modified group members to their current value."
|
|
|
612 (interactive)
|
|
|
613 (let ((children custom-options))
|
|
|
614 (mapc (lambda (child)
|
|
|
615 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
616 (widget-apply child :custom-reset-current)))
|
|
|
617 children)))
|
|
|
618
|
|
|
619 (defun Custom-reset-saved (&rest ignore)
|
|
|
620 "Reset all modified or set group members to their saved value."
|
|
|
621 (interactive)
|
|
|
622 (let ((children custom-options))
|
|
|
623 (mapc (lambda (child)
|
|
|
624 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
625 (widget-apply child :custom-reset-saved)))
|
|
|
626 children)))
|
|
|
627
|
|
|
628 (defun Custom-reset-standard (&rest ignore)
|
|
|
629 "Reset all modified, set, or saved group members to their standard settings."
|
|
|
630 (interactive)
|
|
480
|
631 (let ((all-children custom-options)
|
|
|
632 children must-save)
|
|
428
|
633 (mapc (lambda (child)
|
|
476
|
634 (when (memq (widget-get child :custom-state) '(modified set saved))
|
|
480
|
635 (push child children)))
|
|
|
636 all-children)
|
|
|
637 (let ((the-children children)
|
|
|
638 child)
|
|
|
639 (while (setq child (pop the-children))
|
|
|
640 (and (widget-apply child :custom-pre-reset-standard)
|
|
|
641 (setq must-save t))))
|
|
|
642 (and must-save (custom-save-all))
|
|
|
643 (let ((the-children children)
|
|
|
644 child)
|
|
|
645 (while (setq child (pop the-children))
|
|
|
646 (widget-apply child :custom-post-reset-standard)))
|
|
|
647 ))
|
|
428
|
648
|
|
|
649
|
|
|
650 ;;; The Customize Commands
|
|
|
651
|
|
|
652 (defun custom-prompt-variable (prompt-var prompt-val &optional comment)
|
|
|
653 "Prompt for a variable and a value and return them as a list.
|
|
|
654 PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the
|
|
4178
|
655 prompt for the value. A %s escape in PROMPT-VAL is replaced with
|
|
|
656 the name of the variable. A final colon is appended to both prompts.
|
|
428
|
657
|
|
|
658 If the variable has a `variable-interactive' property, that is used as if
|
|
|
659 it were the arg to `interactive' (which see) to interactively read the value.
|
|
|
660
|
|
|
661 If the variable has a `custom-type' property, it must be a widget and the
|
|
|
662 `:prompt-value' property of that widget will be used for reading the value.
|
|
|
663
|
|
|
664 If optional COMMENT argument is non nil, also prompt for a comment and return
|
|
|
665 it as the third element in the list."
|
|
4178
|
666 (let* ((var (read-variable (concat prompt-var ": ")))
|
|
428
|
667 (minibuffer-help-form '(describe-variable var))
|
|
|
668 (val
|
|
|
669 (let ((prop (get var 'variable-interactive))
|
|
|
670 (type (get var 'custom-type))
|
|
|
671 (prompt (format prompt-val var)))
|
|
|
672 (unless (listp type)
|
|
|
673 (setq type (list type)))
|
|
|
674 (cond (prop
|
|
|
675 ;; Use VAR's `variable-interactive' property
|
|
|
676 ;; as an interactive spec for prompting.
|
|
|
677 (call-interactively (list 'lambda '(arg)
|
|
|
678 (list 'interactive prop)
|
|
|
679 'arg)))
|
|
|
680 (type
|
|
|
681 (widget-prompt-value type
|
|
|
682 prompt
|
|
|
683 (if (boundp var)
|
|
|
684 (symbol-value var))
|
|
|
685 (not (boundp var))))
|
|
|
686 (t
|
|
4178
|
687 (eval-minibuffer (concat prompt ": ")))))))
|
|
428
|
688 (if comment
|
|
|
689 (list var val
|
|
|
690 (read-string "Comment: " (get var 'variable-comment)))
|
|
4178
|
691 (list var val))))
|
|
428
|
692
|
|
|
693 ;;;###autoload
|
|
|
694 (defun customize-set-value (var val &optional comment)
|
|
|
695 "Set VARIABLE to VALUE. VALUE is a Lisp object.
|
|
|
696
|
|
|
697 If VARIABLE has a `variable-interactive' property, that is used as if
|
|
|
698 it were the arg to `interactive' (which see) to interactively read the value.
|
|
|
699
|
|
|
700 If VARIABLE has a `custom-type' property, it must be a widget and the
|
|
|
701 `:prompt-value' property of that widget will be used for reading the value.
|
|
|
702
|
|
|
703 If given a prefix (or a COMMENT argument), also prompt for a comment."
|
|
4178
|
704 (interactive (custom-prompt-variable "Set variable"
|
|
|
705 "Set value of %s"
|
|
428
|
706 current-prefix-arg))
|
|
|
707
|
|
|
708 (set var val)
|
|
|
709 (cond ((string= comment "")
|
|
|
710 (put var 'variable-comment nil))
|
|
|
711 (comment
|
|
|
712 (put var 'variable-comment comment))))
|
|
|
713
|
|
|
714 ;;;###autoload
|
|
444
|
715 (defun customize-set-variable (variable value &optional comment)
|
|
|
716 "Set the default for VARIABLE to VALUE. VALUE is any Lisp object.
|
|
428
|
717
|
|
|
718 If VARIABLE has a `custom-set' property, that is used for setting
|
|
|
719 VARIABLE, otherwise `set-default' is used.
|
|
|
720
|
|
|
721 The `customized-value' property of the VARIABLE will be set to a list
|
|
|
722 with a quoted VALUE as its sole list member.
|
|
|
723
|
|
|
724 If VARIABLE has a `variable-interactive' property, that is used as if
|
|
|
725 it were the arg to `interactive' (which see) to interactively read the value.
|
|
|
726
|
|
|
727 If VARIABLE has a `custom-type' property, it must be a widget and the
|
|
|
728 `:prompt-value' property of that widget will be used for reading the value.
|
|
|
729
|
|
|
730 If given a prefix (or a COMMENT argument), also prompt for a comment."
|
|
4178
|
731 (interactive (custom-prompt-variable "Set variable"
|
|
|
732 "Set customized value of %s"
|
|
428
|
733 current-prefix-arg))
|
|
444
|
734 (funcall (or (get variable 'custom-set) 'set-default) variable value)
|
|
|
735 (put variable 'customized-value (list (custom-quote value)))
|
|
428
|
736 (cond ((string= comment "")
|
|
444
|
737 (put variable 'variable-comment nil)
|
|
|
738 (put variable 'customized-variable-comment nil))
|
|
428
|
739 (comment
|
|
444
|
740 (put variable 'variable-comment comment)
|
|
|
741 (put variable 'customized-variable-comment comment))))
|
|
428
|
742
|
|
|
743
|
|
|
744 ;;;###autoload
|
|
444
|
745 (defun customize-save-variable (variable value &optional comment)
|
|
428
|
746 "Set the default for VARIABLE to VALUE, and save it for future sessions.
|
|
|
747 If VARIABLE has a `custom-set' property, that is used for setting
|
|
|
748 VARIABLE, otherwise `set-default' is used.
|
|
|
749
|
|
|
750 The `customized-value' property of the VARIABLE will be set to a list
|
|
|
751 with a quoted VALUE as its sole list member.
|
|
|
752
|
|
|
753 If VARIABLE has a `variable-interactive' property, that is used as if
|
|
|
754 it were the arg to `interactive' (which see) to interactively read the value.
|
|
|
755
|
|
|
756 If VARIABLE has a `custom-type' property, it must be a widget and the
|
|
|
757 `:prompt-value' property of that widget will be used for reading the value.
|
|
|
758
|
|
|
759 If given a prefix (or a COMMENT argument), also prompt for a comment."
|
|
4178
|
760 (interactive (custom-prompt-variable "Set and save variable"
|
|
|
761 "Set and save value of %s"
|
|
428
|
762 current-prefix-arg))
|
|
444
|
763 (funcall (or (get variable 'custom-set) 'set-default) variable value)
|
|
|
764 (put variable 'saved-value (list (custom-quote value)))
|
|
|
765 (custom-push-theme 'theme-value variable 'user 'set (list (custom-quote value)))
|
|
428
|
766 (cond ((string= comment "")
|
|
444
|
767 (put variable 'variable-comment nil)
|
|
|
768 (put variable 'saved-variable-comment nil))
|
|
428
|
769 (comment
|
|
444
|
770 (put variable 'variable-comment comment)
|
|
|
771 (put variable 'saved-variable-comment comment)))
|
|
428
|
772 (custom-save-all))
|
|
|
773
|
|
|
774 ;;;###autoload
|
|
|
775 (defun customize (group)
|
|
|
776 "Select a customization buffer which you can use to set user options.
|
|
|
777 User options are structured into \"groups\".
|
|
|
778 The default group is `Emacs'."
|
|
|
779 (interactive (custom-group-prompt
|
|
|
780 "Customize group: (default emacs) "))
|
|
|
781 (when (stringp group)
|
|
|
782 (if (string-equal "" group)
|
|
|
783 (setq group 'emacs)
|
|
|
784 (setq group (intern group))))
|
|
|
785 (let ((name (format "*Customize Group: %s*"
|
|
|
786 (custom-unlispify-tag-name group))))
|
|
|
787 (if (get-buffer name)
|
|
|
788 (switch-to-buffer name)
|
|
|
789 (custom-buffer-create (list (list group 'custom-group))
|
|
|
790 name
|
|
|
791 (concat " for group "
|
|
|
792 (custom-unlispify-tag-name group))))))
|
|
|
793
|
|
|
794 ;;;###autoload
|
|
|
795 (defalias 'customize-group 'customize)
|
|
|
796
|
|
|
797 ;;;###autoload
|
|
|
798 (defun customize-other-window (symbol)
|
|
|
799 "Customize SYMBOL, which must be a customization group."
|
|
|
800 (interactive (custom-group-prompt
|
|
|
801 "Customize group: (default emacs) "))
|
|
|
802 (when (stringp symbol)
|
|
|
803 (if (string-equal "" symbol)
|
|
|
804 (setq symbol 'emacs)
|
|
|
805 (setq symbol (intern symbol))))
|
|
|
806 (custom-buffer-create-other-window
|
|
|
807 (list (list symbol 'custom-group))
|
|
|
808 (format "*Customize Group: %s*" (custom-unlispify-tag-name symbol))))
|
|
|
809
|
|
|
810 ;;;###autoload
|
|
|
811 (defalias 'customize-group-other-window 'customize-other-window)
|
|
|
812
|
|
|
813 ;;;###autoload
|
|
|
814 (defalias 'customize-option 'customize-variable)
|
|
|
815
|
|
|
816 ;;;###autoload
|
|
|
817 (defun customize-variable (symbol)
|
|
|
818 "Customize SYMBOL, which must be a user option variable."
|
|
|
819 (interactive (custom-variable-prompt))
|
|
|
820 (custom-buffer-create (list (list symbol 'custom-variable))
|
|
|
821 (format "*Customize Variable: %s*"
|
|
|
822 (custom-unlispify-tag-name symbol))))
|
|
|
823
|
|
|
824 ;;;###autoload
|
|
|
825 (defun customize-changed-options (since-version)
|
|
|
826 "Customize all user option variables whose default values changed recently.
|
|
|
827 This means, in other words, variables defined with a `:version' keyword."
|
|
4289
|
828 (interactive
|
|
|
829 "sCustomize options changed, since version (default all versions): ")
|
|
428
|
830 (if (equal since-version "")
|
|
|
831 (setq since-version nil))
|
|
|
832 (let ((found nil))
|
|
|
833 (mapatoms (lambda (symbol)
|
|
|
834 (and (boundp symbol)
|
|
|
835 (let ((version (get symbol 'custom-version)))
|
|
|
836 (and version
|
|
|
837 (or (null since-version)
|
|
4289
|
838 (customize-version-lessp since-version
|
|
|
839 version))))
|
|
428
|
840 (push (list symbol 'custom-variable) found))))
|
|
|
841 (unless found
|
|
|
842 (error "No user options have changed defaults %s"
|
|
|
843 (if since-version
|
|
|
844 (format "since XEmacs %s" since-version)
|
|
|
845 "in recent Emacs versions")))
|
|
|
846 (custom-buffer-create (custom-sort-items found t nil)
|
|
|
847 "*Customize Changed Options*")))
|
|
|
848
|
|
|
849 (defun customize-version-lessp (version1 version2)
|
|
|
850 (let (major1 major2 minor1 minor2)
|
|
|
851 (string-match "\\([0-9]+\\)[.]\\([0-9]+\\)" version1)
|
|
|
852 (setq major1 (read (match-string 1 version1)))
|
|
|
853 (setq minor1 (read (match-string 2 version1)))
|
|
|
854 (string-match "\\([0-9]+\\)[.]\\([0-9]+\\)" version2)
|
|
|
855 (setq major2 (read (match-string 1 version2)))
|
|
|
856 (setq minor2 (read (match-string 2 version2)))
|
|
|
857 (or (< major1 major2)
|
|
|
858 (and (= major1 major2)
|
|
|
859 (< minor1 minor2)))))
|
|
|
860
|
|
|
861 ;;;###autoload
|
|
|
862 (defalias 'customize-variable-other-window 'customize-option-other-window)
|
|
|
863
|
|
|
864 ;;;###autoload
|
|
|
865 (defun customize-option-other-window (symbol)
|
|
|
866 "Customize SYMBOL, which must be a user option variable.
|
|
|
867 Show the buffer in another window, but don't select it."
|
|
|
868 (interactive (custom-variable-prompt))
|
|
|
869 (custom-buffer-create-other-window
|
|
|
870 (list (list symbol 'custom-variable))
|
|
|
871 (format "*Customize Option: %s*" (custom-unlispify-tag-name symbol))))
|
|
|
872
|
|
|
873 ;;;###autoload
|
|
|
874 (defun customize-face (&optional symbol)
|
|
|
875 "Customize SYMBOL, which should be a face name or nil.
|
|
|
876 If SYMBOL is nil, customize all faces."
|
|
|
877 (interactive (list (completing-read "Customize face: (default all) "
|
|
|
878 obarray 'find-face)))
|
|
|
879 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
|
|
|
880 (custom-buffer-create (custom-sort-items
|
|
|
881 (mapcar (lambda (symbol)
|
|
|
882 (list symbol 'custom-face))
|
|
|
883 (face-list))
|
|
|
884 t nil)
|
|
|
885 "*Customize Faces*")
|
|
|
886 (when (stringp symbol)
|
|
|
887 (setq symbol (intern symbol)))
|
|
|
888 (check-argument-type 'symbolp symbol)
|
|
|
889 (custom-buffer-create (list (list symbol 'custom-face))
|
|
|
890 (format "*Customize Face: %s*"
|
|
|
891 (custom-unlispify-tag-name symbol)))))
|
|
|
892
|
|
|
893 ;;;###autoload
|
|
|
894 (defun customize-face-other-window (&optional symbol)
|
|
|
895 "Show customization buffer for FACE in other window."
|
|
|
896 (interactive (list (completing-read "Customize face: "
|
|
|
897 obarray 'find-face)))
|
|
|
898 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
|
|
|
899 ()
|
|
|
900 (if (stringp symbol)
|
|
|
901 (setq symbol (intern symbol)))
|
|
|
902 (check-argument-type 'symbolp symbol)
|
|
|
903 (custom-buffer-create-other-window
|
|
|
904 (list (list symbol 'custom-face))
|
|
|
905 (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol)))))
|
|
|
906
|
|
|
907 ;;;###autoload
|
|
|
908 (defun customize-customized ()
|
|
|
909 "Customize all user options set since the last save in this session."
|
|
|
910 (interactive)
|
|
|
911 (let ((found nil))
|
|
|
912 (mapatoms (lambda (symbol)
|
|
|
913 (and (or (get symbol 'customized-face)
|
|
|
914 (get symbol 'customized-face-comment))
|
|
|
915 (find-face symbol)
|
|
|
916 (push (list symbol 'custom-face) found))
|
|
|
917 (and (or (get symbol 'customized-value)
|
|
|
918 (get symbol 'customized-variable-comment))
|
|
|
919 (boundp symbol)
|
|
|
920 (push (list symbol 'custom-variable) found))))
|
|
|
921 (if (not found)
|
|
|
922 (error "No customized user options")
|
|
|
923 (custom-buffer-create (custom-sort-items found t nil)
|
|
|
924 "*Customize Customized*"))))
|
|
|
925
|
|
|
926 ;;;###autoload
|
|
|
927 (defun customize-saved ()
|
|
|
928 "Customize all already saved user options."
|
|
|
929 (interactive)
|
|
|
930 (let ((found nil))
|
|
|
931 (mapatoms (lambda (symbol)
|
|
|
932 (and (or (get symbol 'saved-face)
|
|
|
933 (get symbol 'saved-face-comment))
|
|
|
934 (find-face symbol)
|
|
|
935 (push (list symbol 'custom-face) found))
|
|
|
936 (and (or (get symbol 'saved-value)
|
|
|
937 (get symbol 'saved-variable-comment))
|
|
|
938 (boundp symbol)
|
|
|
939 (push (list symbol 'custom-variable) found))))
|
|
|
940 (if (not found )
|
|
|
941 (error "No saved user options")
|
|
|
942 (custom-buffer-create (custom-sort-items found t nil)
|
|
|
943 "*Customize Saved*"))))
|
|
|
944
|
|
|
945 ;;;###autoload
|
|
1655
|
946 (defalias 'apropos-customize 'customize-apropos)
|
|
|
947
|
|
|
948 ;;;###autoload
|
|
428
|
949 (defun customize-apropos (regexp &optional all)
|
|
|
950 "Customize all user options matching REGEXP.
|
|
|
951 If ALL is `options', include only options.
|
|
|
952 If ALL is `faces', include only faces.
|
|
|
953 If ALL is `groups', include only groups.
|
|
|
954 If ALL is t (interactively, with prefix arg), include options which are not
|
|
|
955 user-settable, as well as faces and groups."
|
|
|
956 (interactive "sCustomize regexp: \nP")
|
|
|
957 (let ((found nil))
|
|
|
958 (mapatoms (lambda (symbol)
|
|
|
959 (when (string-match regexp (symbol-name symbol))
|
|
|
960 (when (and (not (memq all '(faces options)))
|
|
|
961 (get symbol 'custom-group))
|
|
|
962 (push (list symbol 'custom-group) found))
|
|
|
963 (when (and (not (memq all '(options groups)))
|
|
|
964 (find-face symbol))
|
|
|
965 (push (list symbol 'custom-face) found))
|
|
|
966 (when (and (not (memq all '(groups faces)))
|
|
|
967 (boundp symbol)
|
|
|
968 (or (get symbol 'saved-value)
|
|
|
969 (get symbol 'standard-value)
|
|
|
970 (if (memq all '(nil options))
|
|
|
971 (user-variable-p symbol)
|
|
|
972 (get symbol 'variable-documentation))))
|
|
|
973 (push (list symbol 'custom-variable) found)))))
|
|
|
974 (if (not found)
|
|
|
975 (error "No matches")
|
|
|
976 (custom-buffer-create (custom-sort-items found t
|
|
|
977 custom-buffer-order-groups)
|
|
|
978 "*Customize Apropos*"))))
|
|
|
979
|
|
|
980 ;;;###autoload
|
|
|
981 (defun customize-apropos-options (regexp &optional arg)
|
|
|
982 "Customize all user options matching REGEXP.
|
|
|
983 With prefix arg, include options which are not user-settable."
|
|
|
984 (interactive "sCustomize regexp: \nP")
|
|
|
985 (customize-apropos regexp (or arg 'options)))
|
|
|
986
|
|
|
987 ;;;###autoload
|
|
|
988 (defun customize-apropos-faces (regexp)
|
|
|
989 "Customize all user faces matching REGEXP."
|
|
|
990 (interactive "sCustomize regexp: \n")
|
|
|
991 (customize-apropos regexp 'faces))
|
|
|
992
|
|
|
993 ;;;###autoload
|
|
|
994 (defun customize-apropos-groups (regexp)
|
|
|
995 "Customize all user groups matching REGEXP."
|
|
|
996 (interactive "sCustomize regexp: \n")
|
|
|
997 (customize-apropos regexp 'groups))
|
|
|
998
|
|
|
999
|
|
|
1000 ;;; Buffer.
|
|
|
1001
|
|
|
1002 (defcustom custom-buffer-style 'links
|
|
|
1003 "*Control the presentation style for customization buffers.
|
|
|
1004 The value should be a symbol, one of:
|
|
|
1005
|
|
|
1006 brackets: groups nest within each other with big horizontal brackets.
|
|
|
1007 links: groups have links to subgroups."
|
|
|
1008 :type '(radio (const :tag "brackets: Groups nest within each others" brackets)
|
|
|
1009 (const :tag "links: Group have links to subgroups" links))
|
|
|
1010 :group 'custom-buffer)
|
|
|
1011
|
|
|
1012 (defcustom custom-buffer-done-function 'kill-buffer
|
|
|
1013 "*Function to be used to remove the buffer when the user is done with it.
|
|
|
1014 Choices include `kill-buffer' (the default) and `bury-buffer'.
|
|
|
1015 The function will be called with one argument, the buffer to remove."
|
|
|
1016 :type '(radio (function-item kill-buffer)
|
|
|
1017 (function-item bury-buffer)
|
|
|
1018 (function :tag "Other" nil))
|
|
|
1019 :group 'custom-buffer)
|
|
|
1020
|
|
|
1021 (defcustom custom-buffer-indent 3
|
|
|
1022 "Number of spaces to indent nested groups."
|
|
|
1023 :type 'integer
|
|
|
1024 :group 'custom-buffer)
|
|
|
1025
|
|
|
1026 ;;;###autoload
|
|
|
1027 (defun custom-buffer-create (options &optional name description)
|
|
|
1028 "Create a buffer containing OPTIONS.
|
|
|
1029 Optional NAME is the name of the buffer.
|
|
|
1030 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
|
|
|
1031 SYMBOL is a customization option, and WIDGET is a widget for editing
|
|
|
1032 that option."
|
|
|
1033 (unless name (setq name "*Customization*"))
|
|
|
1034 (kill-buffer (get-buffer-create name))
|
|
|
1035 (switch-to-buffer (get-buffer-create name))
|
|
|
1036 (custom-buffer-create-internal options description))
|
|
|
1037
|
|
|
1038 ;;;###autoload
|
|
|
1039 (defun custom-buffer-create-other-window (options &optional name description)
|
|
|
1040 "Create a buffer containing OPTIONS.
|
|
|
1041 Optional NAME is the name of the buffer.
|
|
|
1042 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
|
|
|
1043 SYMBOL is a customization option, and WIDGET is a widget for editing
|
|
|
1044 that option."
|
|
|
1045 (unless name (setq name "*Customization*"))
|
|
|
1046 (kill-buffer (get-buffer-create name))
|
|
|
1047 (let ((window (selected-window)))
|
|
|
1048 (switch-to-buffer-other-window (get-buffer-create name))
|
|
|
1049 (custom-buffer-create-internal options description)
|
|
|
1050 (select-window window)))
|
|
|
1051
|
|
|
1052 (defcustom custom-reset-button-menu t
|
|
|
1053 "If non-nil, only show a single reset button in customize buffers.
|
|
|
1054 This button will have a menu with all three reset operations."
|
|
|
1055 :type 'boolean
|
|
|
1056 :group 'custom-buffer)
|
|
|
1057
|
|
|
1058 (defconst custom-skip-messages 5)
|
|
|
1059
|
|
|
1060 (defun Custom-buffer-done ()
|
|
|
1061 "Remove current buffer.
|
|
|
1062 This works by calling the function specified by
|
|
|
1063 `custom-buffer-done-function'."
|
|
|
1064 (interactive)
|
|
|
1065 (funcall custom-buffer-done-function (current-buffer)))
|
|
|
1066
|
|
|
1067 (defun custom-buffer-create-buttons ()
|
|
|
1068 (message "Creating customization buttons...")
|
|
|
1069 (widget-insert "\nOperate on everything in this buffer:\n ")
|
|
|
1070 (widget-create 'push-button
|
|
|
1071 :tag "Set"
|
|
|
1072 :help-echo "\
|
|
|
1073 Make your editing in this buffer take effect for this session"
|
|
|
1074 :action (lambda (widget &optional event)
|
|
|
1075 (Custom-set)))
|
|
|
1076 (widget-insert " ")
|
|
|
1077 (widget-create 'push-button
|
|
|
1078 :tag "Save"
|
|
|
1079 :help-echo "\
|
|
|
1080 Make your editing in this buffer take effect for future Emacs sessions"
|
|
|
1081 :action (lambda (widget &optional event)
|
|
|
1082 (Custom-save)))
|
|
|
1083 (if custom-reset-button-menu
|
|
|
1084 (progn
|
|
|
1085 (widget-insert " ")
|
|
|
1086 (widget-create 'push-button
|
|
|
1087 :tag "Reset"
|
|
|
1088 :tag-glyph '("reset-up" "reset-down")
|
|
|
1089 :help-echo "Show a menu with reset operations"
|
|
|
1090 :mouse-down-action (lambda (&rest junk) t)
|
|
|
1091 :action (lambda (widget &optional event)
|
|
|
1092 (custom-reset event))))
|
|
|
1093 (widget-insert " ")
|
|
|
1094 (widget-create 'push-button
|
|
|
1095 :tag "Reset"
|
|
|
1096 :help-echo "\
|
|
|
1097 Reset all edited text in this buffer to reflect current values"
|
|
|
1098 :action 'Custom-reset-current)
|
|
|
1099 (widget-insert " ")
|
|
|
1100 (widget-create 'push-button
|
|
|
1101 :tag "Reset to Saved"
|
|
|
1102 :help-echo "\
|
|
|
1103 Reset all values in this buffer to their saved settings"
|
|
|
1104 :action 'Custom-reset-saved)
|
|
|
1105 (widget-insert " ")
|
|
|
1106 (widget-create 'push-button
|
|
|
1107 :tag "Reset to Standard"
|
|
|
1108 :help-echo "\
|
|
|
1109 Reset all values in this buffer to their standard settings"
|
|
|
1110 :action 'Custom-reset-standard))
|
|
|
1111 (widget-insert " ")
|
|
|
1112 (widget-create 'push-button
|
|
|
1113 :tag "Done"
|
|
|
1114 :help-echo "Remove the buffer"
|
|
|
1115 :action (lambda (widget &optional event)
|
|
|
1116 (Custom-buffer-done)))
|
|
|
1117 (widget-insert "\n"))
|
|
|
1118
|
|
|
1119 (defcustom custom-novice t
|
|
|
1120 "If non-nil, show help message at top of customize buffers."
|
|
|
1121 :type 'boolean
|
|
|
1122 :group 'custom-buffer)
|
|
|
1123
|
|
|
1124 (defcustom custom-display-global-buttons 'top
|
|
|
1125 "If `nil' don't display the global buttons. If `top' display at the
|
|
|
1126 beginning of custom buffers. If `bottom', display at the end."
|
|
|
1127 :type '(choice (const top)
|
|
|
1128 (const bottom)
|
|
|
1129 (const :tag "don't" nil))
|
|
|
1130 :group 'custom-buffer)
|
|
|
1131
|
|
|
1132 (defun custom-buffer-create-internal (options &optional description)
|
|
|
1133 (message "Creating customization buffer...")
|
|
|
1134 (custom-mode)
|
|
|
1135 (widget-insert "This is a customization buffer")
|
|
|
1136 (if description
|
|
|
1137 (widget-insert description))
|
|
|
1138 (when custom-novice
|
|
|
1139 (widget-insert ".\n\
|
|
|
1140 Type RET or click button2 on an active field to invoke its action.
|
|
|
1141 Invoke ")
|
|
|
1142 (widget-create 'info-link
|
|
|
1143 :tag "Help"
|
|
|
1144 :help-echo "Read the online help"
|
|
|
1145 "(XEmacs)Easy Customization")
|
|
|
1146 (widget-insert " for more information."))
|
|
|
1147 (widget-insert "\n")
|
|
|
1148 (if (equal custom-display-global-buttons 'top)
|
|
|
1149 (custom-buffer-create-buttons))
|
|
|
1150 (widget-insert "\n")
|
|
|
1151 (message "Creating customization items...")
|
|
|
1152 (setq custom-options
|
|
|
1153 (if (= (length options) 1)
|
|
|
1154 (mapcar (lambda (entry)
|
|
|
1155 (widget-create (nth 1 entry)
|
|
|
1156 :documentation-shown t
|
|
|
1157 :custom-state 'unknown
|
|
|
1158 :tag (custom-unlispify-tag-name
|
|
|
1159 (nth 0 entry))
|
|
|
1160 :value (nth 0 entry)))
|
|
|
1161 options)
|
|
|
1162 (let ((count 0)
|
|
|
1163 (length (length options)))
|
|
|
1164 (mapcar (lambda (entry)
|
|
|
1165 (prog2
|
|
|
1166 (display-message
|
|
|
1167 'progress
|
|
|
1168 (format "Creating customization items %2d%%..."
|
|
|
1169 (/ (* 100.0 count) length)))
|
|
|
1170 (widget-create (nth 1 entry)
|
|
|
1171 :tag (custom-unlispify-tag-name
|
|
|
1172 (nth 0 entry))
|
|
|
1173 :value (nth 0 entry))
|
|
|
1174 (incf count)
|
|
|
1175 (unless (eq (preceding-char) ?\n)
|
|
|
1176 (widget-insert "\n"))
|
|
|
1177 (widget-insert "\n")))
|
|
|
1178 options))))
|
|
|
1179 (unless (eq (preceding-char) ?\n)
|
|
|
1180 (widget-insert "\n"))
|
|
|
1181 (if (equal custom-display-global-buttons 'bottom)
|
|
|
1182 (custom-buffer-create-buttons))
|
|
|
1183 (display-message 'progress
|
|
|
1184 (format
|
|
|
1185 "Creating customization items %2d%%...done" 100))
|
|
|
1186 (unless (eq custom-buffer-style 'tree)
|
|
|
1187 (mapc 'custom-magic-reset custom-options))
|
|
|
1188 (message "Creating customization setup...")
|
|
|
1189 (widget-setup)
|
|
|
1190 (goto-char (point-min))
|
|
|
1191 (message "Creating customization buffer...done"))
|
|
|
1192
|
|
|
1193
|
|
|
1194 ;;; The Tree Browser.
|
|
|
1195
|
|
|
1196 ;;;###autoload
|
|
|
1197 (defun customize-browse (&optional group)
|
|
|
1198 "Create a tree browser for the customize hierarchy."
|
|
|
1199 (interactive)
|
|
|
1200 (unless group
|
|
|
1201 (setq group 'emacs))
|
|
|
1202 (let ((name "*Customize Browser*"))
|
|
|
1203 (kill-buffer (get-buffer-create name))
|
|
|
1204 (switch-to-buffer (get-buffer-create name)))
|
|
|
1205 (custom-mode)
|
|
|
1206 (widget-insert "\
|
|
|
1207 Square brackets show active fields; type RET or click button2
|
|
|
1208 on an active field to invoke its action.
|
|
|
1209 Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n")
|
|
|
1210 (if custom-browse-only-groups
|
|
|
1211 (widget-insert "\
|
|
|
1212 Invoke the [Group] button below to edit that item in another window.\n\n")
|
|
|
1213 (widget-insert "Invoke the ")
|
|
|
1214 (widget-create 'item
|
|
|
1215 :format "%t"
|
|
|
1216 :tag "[Group]"
|
|
|
1217 :tag-glyph "folder")
|
|
|
1218 (widget-insert ", ")
|
|
|
1219 (widget-create 'item
|
|
|
1220 :format "%t"
|
|
|
1221 :tag "[Face]"
|
|
|
1222 :tag-glyph "face")
|
|
|
1223 (widget-insert ", and ")
|
|
|
1224 (widget-create 'item
|
|
|
1225 :format "%t"
|
|
|
1226 :tag "[Option]"
|
|
|
1227 :tag-glyph "option")
|
|
|
1228 (widget-insert " buttons below to edit that
|
|
|
1229 item in another window.\n\n"))
|
|
|
1230 (let ((custom-buffer-style 'tree))
|
|
|
1231 (widget-create 'custom-group
|
|
|
1232 :custom-last t
|
|
|
1233 :custom-state 'unknown
|
|
|
1234 :tag (custom-unlispify-tag-name group)
|
|
|
1235 :value group))
|
|
|
1236 (widget-add-change)
|
|
|
1237 (goto-char (point-min)))
|
|
|
1238
|
|
|
1239 (define-widget 'custom-browse-visibility 'item
|
|
2118
|
1240 "Control visibility of items in the customize tree browser."
|
|
428
|
1241 :format "%[[%t]%]"
|
|
|
1242 :action 'custom-browse-visibility-action)
|
|
|
1243
|
|
|
1244 (defun custom-browse-visibility-action (widget &rest ignore)
|
|
|
1245 (let ((custom-buffer-style 'tree))
|
|
|
1246 (custom-toggle-parent widget)))
|
|
|
1247
|
|
|
1248 (define-widget 'custom-browse-group-tag 'push-button
|
|
|
1249 "Show parent in other window when activated."
|
|
|
1250 :tag "Group"
|
|
|
1251 :tag-glyph "folder"
|
|
|
1252 :action 'custom-browse-group-tag-action)
|
|
|
1253
|
|
|
1254 (defun custom-browse-group-tag-action (widget &rest ignore)
|
|
|
1255 (let ((parent (widget-get widget :parent)))
|
|
|
1256 (customize-group-other-window (widget-value parent))))
|
|
|
1257
|
|
|
1258 (define-widget 'custom-browse-variable-tag 'push-button
|
|
|
1259 "Show parent in other window when activated."
|
|
|
1260 :tag "Option"
|
|
|
1261 :tag-glyph "option"
|
|
|
1262 :action 'custom-browse-variable-tag-action)
|
|
|
1263
|
|
|
1264 (defun custom-browse-variable-tag-action (widget &rest ignore)
|
|
|
1265 (let ((parent (widget-get widget :parent)))
|
|
|
1266 (customize-variable-other-window (widget-value parent))))
|
|
|
1267
|
|
|
1268 (define-widget 'custom-browse-face-tag 'push-button
|
|
|
1269 "Show parent in other window when activated."
|
|
|
1270 :tag "Face"
|
|
|
1271 :tag-glyph "face"
|
|
|
1272 :action 'custom-browse-face-tag-action)
|
|
|
1273
|
|
|
1274 (defun custom-browse-face-tag-action (widget &rest ignore)
|
|
|
1275 (let ((parent (widget-get widget :parent)))
|
|
|
1276 (customize-face-other-window (widget-value parent))))
|
|
|
1277
|
|
|
1278 (defconst custom-browse-alist '((" " "space")
|
|
|
1279 (" | " "vertical")
|
|
|
1280 ("-\\ " "top")
|
|
|
1281 (" |-" "middle")
|
|
|
1282 (" `-" "bottom")))
|
|
|
1283
|
|
|
1284 (defun custom-browse-insert-prefix (prefix)
|
|
|
1285 "Insert PREFIX. On XEmacs convert it to line graphics."
|
|
440
|
1286 ;; #### Unfinished.
|
|
428
|
1287 (if nil ; (string-match "XEmacs" emacs-version)
|
|
|
1288 (progn
|
|
|
1289 (insert "*")
|
|
|
1290 (while (not (string-equal prefix ""))
|
|
|
1291 (let ((entry (substring prefix 0 3)))
|
|
|
1292 (setq prefix (substring prefix 3))
|
|
|
1293 (let ((overlay (make-overlay (1- (point)) (point) nil t nil))
|
|
|
1294 (name (nth 1 (assoc entry custom-browse-alist))))
|
|
|
1295 (overlay-put overlay 'end-glyph (widget-glyph-find name entry))
|
|
|
1296 (overlay-put overlay 'start-open t)
|
|
|
1297 (overlay-put overlay 'end-open t)))))
|
|
|
1298 (insert prefix)))
|
|
|
1299
|
|
|
1300
|
|
|
1301 ;;; Modification of Basic Widgets.
|
|
|
1302 ;;
|
|
|
1303 ;; We add extra properties to the basic widgets needed here. This is
|
|
|
1304 ;; fine, as long as we are careful to stay within out own namespace.
|
|
|
1305 ;;
|
|
|
1306 ;; We want simple widgets to be displayed by default, but complex
|
|
|
1307 ;; widgets to be hidden.
|
|
|
1308
|
|
|
1309 (widget-put (get 'item 'widget-type) :custom-show t)
|
|
|
1310 (widget-put (get 'editable-field 'widget-type)
|
|
|
1311 :custom-show (lambda (widget value)
|
|
|
1312 ;; This used to call pp-to-string
|
|
|
1313 (let ((pp (widget-prettyprint-to-string value)))
|
|
|
1314 (cond ((string-match "\n" pp)
|
|
|
1315 nil)
|
|
|
1316 ((> (length pp) 40)
|
|
|
1317 nil)
|
|
|
1318 (t t)))))
|
|
|
1319 (widget-put (get 'menu-choice 'widget-type) :custom-show t)
|
|
|
1320
|
|
|
1321 ;;; The `custom-manual' Widget.
|
|
|
1322
|
|
|
1323 (define-widget 'custom-manual 'info-link
|
|
|
1324 "Link to the manual entry for this customization option."
|
|
|
1325 :tag "Manual")
|
|
|
1326
|
|
|
1327 ;;; The `custom-magic' Widget.
|
|
|
1328
|
|
|
1329 (defgroup custom-magic-faces nil
|
|
|
1330 "Faces used by the magic button."
|
|
|
1331 :group 'custom-faces
|
|
|
1332 :group 'custom-buffer)
|
|
|
1333
|
|
|
1334 (defface custom-invalid-face '((((class color))
|
|
|
1335 (:foreground "yellow" :background "red"))
|
|
|
1336 (t
|
|
|
1337 (:bold t :italic t :underline t)))
|
|
|
1338 "Face used when the customize item is invalid."
|
|
|
1339 :group 'custom-magic-faces)
|
|
|
1340
|
|
|
1341 (defface custom-rogue-face '((((class color))
|
|
|
1342 (:foreground "pink" :background "black"))
|
|
|
1343 (t
|
|
|
1344 (:underline t)))
|
|
|
1345 "Face used when the customize item is not defined for customization."
|
|
|
1346 :group 'custom-magic-faces)
|
|
|
1347
|
|
|
1348 (defface custom-modified-face '((((class color))
|
|
|
1349 (:foreground "white" :background "blue"))
|
|
|
1350 (t
|
|
|
1351 (:italic t :bold)))
|
|
|
1352 "Face used when the customize item has been modified."
|
|
|
1353 :group 'custom-magic-faces)
|
|
|
1354
|
|
|
1355 (defface custom-set-face '((((class color))
|
|
|
1356 (:foreground "blue" :background "white"))
|
|
|
1357 (t
|
|
|
1358 (:italic t)))
|
|
|
1359 "Face used when the customize item has been set."
|
|
|
1360 :group 'custom-magic-faces)
|
|
|
1361
|
|
|
1362 (defface custom-changed-face '((((class color))
|
|
|
1363 (:foreground "white" :background "blue"))
|
|
|
1364 (t
|
|
|
1365 (:italic t)))
|
|
|
1366 "Face used when the customize item has been changed."
|
|
|
1367 :group 'custom-magic-faces)
|
|
|
1368
|
|
|
1369 (defface custom-saved-face '((t (:underline t)))
|
|
|
1370 "Face used when the customize item has been saved."
|
|
|
1371 :group 'custom-magic-faces)
|
|
|
1372
|
|
|
1373 (defconst custom-magic-alist '((nil "#" underline "\
|
|
|
1374 uninitialized, you should not see this.")
|
|
|
1375 (unknown "?" italic "\
|
|
|
1376 unknown, you should not see this.")
|
|
|
1377 (hidden "-" default "\
|
|
|
1378 hidden, invoke \"Show\" button in the previous line to show." "\
|
|
|
1379 group now hidden, invoke the above \"Show\" button to show contents.")
|
|
|
1380 (invalid "x" custom-invalid-face "\
|
|
|
1381 the value displayed for this %c is invalid and cannot be set.")
|
|
|
1382 (modified "*" custom-modified-face "\
|
|
|
1383 you have edited the value as text, but you have not set the %c." "\
|
|
|
1384 you have edited something in this group, but not set it.")
|
|
|
1385 (set "+" custom-set-face "\
|
|
|
1386 you have set this %c, but not saved it for future sessions." "\
|
|
|
1387 something in this group has been set, but not saved.")
|
|
|
1388 (changed ":" custom-changed-face "\
|
|
|
1389 this %c has been changed outside the customize buffer." "\
|
|
|
1390 something in this group has been changed outside customize.")
|
|
|
1391 (saved "!" custom-saved-face "\
|
|
|
1392 this %c has been set and saved." "\
|
|
|
1393 something in this group has been set and saved.")
|
|
|
1394 (rogue "@" custom-rogue-face "\
|
|
|
1395 this %c has not been changed with customize." "\
|
|
|
1396 something in this group is not prepared for customization.")
|
|
|
1397 (standard " " nil "\
|
|
|
1398 this %c is unchanged from its standard setting." "\
|
|
|
1399 visible group members are all at standard settings."))
|
|
|
1400 "Alist of customize option states.
|
|
|
1401 Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where
|
|
|
1402
|
|
|
1403 STATE is one of the following symbols:
|
|
|
1404
|
|
|
1405 `nil'
|
|
|
1406 For internal use, should never occur.
|
|
|
1407 `unknown'
|
|
|
1408 For internal use, should never occur.
|
|
|
1409 `hidden'
|
|
|
1410 This item is not being displayed.
|
|
|
1411 `invalid'
|
|
|
1412 This item is modified, but has an invalid form.
|
|
|
1413 `modified'
|
|
|
1414 This item is modified, and has a valid form.
|
|
|
1415 `set'
|
|
|
1416 This item has been set but not saved.
|
|
|
1417 `changed'
|
|
|
1418 The current value of this item has been changed temporarily.
|
|
|
1419 `saved'
|
|
|
1420 This item is marked for saving.
|
|
|
1421 `rogue'
|
|
|
1422 This item has no customization information.
|
|
|
1423 `standard'
|
|
|
1424 This item is unchanged from the standard setting.
|
|
|
1425
|
|
|
1426 MAGIC is a string used to present that state.
|
|
|
1427
|
|
|
1428 FACE is a face used to present the state.
|
|
|
1429
|
|
|
1430 ITEM-DESC is a string describing the state for options.
|
|
|
1431
|
|
|
1432 GROUP-DESC is a string describing the state for groups. If this is
|
|
|
1433 left out, ITEM-DESC will be used.
|
|
|
1434
|
|
|
1435 The string %c in either description will be replaced with the
|
|
|
1436 category of the item. These are `group'. `option', and `face'.
|
|
|
1437
|
|
|
1438 The list should be sorted most significant first.")
|
|
|
1439
|
|
|
1440 (defcustom custom-magic-show 'long
|
|
|
1441 "If non-nil, show textual description of the state.
|
|
|
1442 If `long', show a full-line description, not just one word."
|
|
|
1443 :type '(choice (const :tag "no" nil)
|
|
|
1444 (const short)
|
|
|
1445 (const long))
|
|
|
1446 :group 'custom-buffer)
|
|
|
1447
|
|
|
1448 (defcustom custom-magic-show-hidden '(option face)
|
|
|
1449 "Control whether the State button is shown for hidden items.
|
|
|
1450 The value should be a list with the custom categories where the State
|
|
|
1451 button should be visible. Possible categories are `group', `option',
|
|
|
1452 and `face'."
|
|
|
1453 :type '(set (const group) (const option) (const face))
|
|
|
1454 :group 'custom-buffer)
|
|
|
1455
|
|
|
1456 (defcustom custom-magic-show-button nil
|
|
|
1457 "Show a \"magic\" button indicating the state of each customization option."
|
|
|
1458 :type 'boolean
|
|
|
1459 :group 'custom-buffer)
|
|
|
1460
|
|
|
1461 (define-widget 'custom-magic 'default
|
|
|
1462 "Show and manipulate state for a customization option."
|
|
|
1463 :format "%v"
|
|
|
1464 :action 'widget-parent-action
|
|
|
1465 :notify 'ignore
|
|
|
1466 :value-get 'ignore
|
|
|
1467 :value-create 'custom-magic-value-create
|
|
|
1468 :value-delete 'widget-children-value-delete)
|
|
|
1469
|
|
|
1470 (defun widget-magic-mouse-down-action (widget &optional event)
|
|
|
1471 ;; Non-nil unless hidden.
|
|
|
1472 (not (eq (widget-get (widget-get (widget-get widget :parent) :parent)
|
|
|
1473 :custom-state)
|
|
|
1474 'hidden)))
|
|
|
1475
|
|
|
1476 (defun custom-magic-value-create (widget)
|
|
|
1477 ;; Create compact status report for WIDGET.
|
|
|
1478 (let* ((parent (widget-get widget :parent))
|
|
|
1479 (state (widget-get parent :custom-state))
|
|
|
1480 (hidden (eq state 'hidden))
|
|
|
1481 (entry (assq state custom-magic-alist))
|
|
|
1482 (magic (nth 1 entry))
|
|
|
1483 (face (nth 2 entry))
|
|
|
1484 (category (widget-get parent :custom-category))
|
|
|
1485 (text (or (and (eq category 'group)
|
|
|
1486 (nth 4 entry))
|
|
|
1487 (nth 3 entry)))
|
|
|
1488 (form (widget-get parent :custom-form))
|
|
|
1489 children)
|
|
|
1490 (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text)
|
|
|
1491 (setq text (concat (match-string 1 text)
|
|
|
1492 (symbol-name category)
|
|
|
1493 (match-string 2 text))))
|
|
|
1494 (when (and custom-magic-show
|
|
|
1495 (or (not hidden)
|
|
|
1496 (memq category custom-magic-show-hidden)))
|
|
|
1497 (insert " ")
|
|
|
1498 (when (and (eq category 'group)
|
|
|
1499 (not (and (eq custom-buffer-style 'links)
|
|
|
1500 (> (widget-get parent :custom-level) 1))))
|
|
|
1501 (insert-char ?\ (* custom-buffer-indent
|
|
|
1502 (widget-get parent :custom-level))))
|
|
|
1503 (push (widget-create-child-and-convert
|
|
|
1504 widget 'choice-item
|
|
|
1505 :help-echo "Change the state of this item"
|
|
|
1506 :format (if hidden "%t" "%[%t%]")
|
|
|
1507 :button-prefix 'widget-push-button-prefix
|
|
|
1508 :button-suffix 'widget-push-button-suffix
|
|
|
1509 :mouse-down-action 'widget-magic-mouse-down-action
|
|
|
1510 :tag "State"
|
|
|
1511 ;;:tag-glyph (or hidden '("state-up" "state-down"))
|
|
|
1512 )
|
|
|
1513 children)
|
|
|
1514 (insert ": ")
|
|
|
1515 (let ((start (point)))
|
|
|
1516 (if (eq custom-magic-show 'long)
|
|
|
1517 (insert text)
|
|
|
1518 (insert (symbol-name state)))
|
|
|
1519 (cond ((eq form 'lisp)
|
|
|
1520 (insert " (lisp)"))
|
|
|
1521 ((eq form 'mismatch)
|
|
|
1522 (insert " (mismatch)")))
|
|
|
1523 (put-text-property start (point) 'face 'custom-state-face))
|
|
|
1524 (insert "\n"))
|
|
|
1525 (when (and (eq category 'group)
|
|
|
1526 (not (and (eq custom-buffer-style 'links)
|
|
|
1527 (> (widget-get parent :custom-level) 1))))
|
|
|
1528 (insert-char ?\ (* custom-buffer-indent
|
|
|
1529 (widget-get parent :custom-level))))
|
|
|
1530 (when custom-magic-show-button
|
|
|
1531 (when custom-magic-show
|
|
|
1532 (let ((indent (widget-get parent :indent)))
|
|
|
1533 (when indent
|
|
|
1534 (insert-char ?\ indent))))
|
|
|
1535 (push (widget-create-child-and-convert
|
|
|
1536 widget 'choice-item
|
|
|
1537 :mouse-down-action 'widget-magic-mouse-down-action
|
|
|
1538 :button-face face
|
|
|
1539 :button-prefix ""
|
|
|
1540 :button-suffix ""
|
|
|
1541 :help-echo "Change the state"
|
|
|
1542 :format (if hidden "%t" "%[%t%]")
|
|
|
1543 :tag (if (memq form '(lisp mismatch))
|
|
|
1544 (concat "(" magic ")")
|
|
|
1545 (concat "[" magic "]")))
|
|
|
1546 children)
|
|
|
1547 (insert " "))
|
|
|
1548 (widget-put widget :children children)))
|
|
|
1549
|
|
|
1550 (defun custom-magic-reset (widget)
|
|
|
1551 "Redraw the :custom-magic property of WIDGET."
|
|
|
1552 (let ((magic (widget-get widget :custom-magic)))
|
|
|
1553 (widget-value-set magic (widget-value magic))))
|
|
|
1554
|
|
|
1555 ;;; The `custom' Widget.
|
|
|
1556
|
|
|
1557 (defface custom-button-face '((t (:bold t)))
|
|
|
1558 "Face used for buttons in customization buffers."
|
|
|
1559 :group 'custom-faces)
|
|
|
1560
|
|
|
1561 (defface custom-documentation-face nil
|
|
|
1562 "Face used for documentation strings in customization buffers."
|
|
|
1563 :group 'custom-faces)
|
|
|
1564
|
|
|
1565 (defface custom-state-face '((((class color)
|
|
|
1566 (background dark))
|
|
|
1567 (:foreground "lime green"))
|
|
|
1568 (((class color)
|
|
|
1569 (background light))
|
|
|
1570 (:foreground "dark green"))
|
|
|
1571 (t nil))
|
|
|
1572 "Face used for State descriptions in the customize buffer."
|
|
|
1573 :group 'custom-faces)
|
|
|
1574
|
|
|
1575 (define-widget 'custom 'default
|
|
|
1576 "Customize a user option."
|
|
|
1577 :format "%v"
|
|
|
1578 :convert-widget 'custom-convert-widget
|
|
|
1579 :notify 'custom-notify
|
|
|
1580 :custom-prefix ""
|
|
|
1581 :custom-level 1
|
|
|
1582 :custom-state 'hidden
|
|
|
1583 :documentation-property 'widget-subclass-responsibility
|
|
|
1584 :value-create 'widget-subclass-responsibility
|
|
|
1585 :value-delete 'widget-children-value-delete
|
|
|
1586 :value-get 'widget-value-value-get
|
|
|
1587 :validate 'widget-children-validate
|
|
|
1588 :match (lambda (widget value) (symbolp value)))
|
|
|
1589
|
|
|
1590 (defun custom-convert-widget (widget)
|
|
|
1591 ;; Initialize :value and :tag from :args in WIDGET.
|
|
|
1592 (let ((args (widget-get widget :args)))
|
|
|
1593 (when args
|
|
|
1594 (widget-put widget :value (widget-apply widget
|
|
|
1595 :value-to-internal (car args)))
|
|
|
1596 (widget-put widget :tag (custom-unlispify-tag-name (car args)))
|
|
|
1597 (widget-put widget :args nil)))
|
|
|
1598 widget)
|
|
|
1599
|
|
|
1600 (defun custom-notify (widget &rest args)
|
|
|
1601 "Keep track of changes."
|
|
|
1602 (let ((state (widget-get widget :custom-state)))
|
|
|
1603 (unless (eq state 'modified)
|
|
|
1604 (unless (memq state '(nil unknown hidden))
|
|
|
1605 (widget-put widget :custom-state 'modified))
|
|
|
1606 (custom-magic-reset widget)
|
|
|
1607 (apply 'widget-default-notify widget args))))
|
|
|
1608
|
|
|
1609 (defun custom-redraw (widget)
|
|
|
1610 "Redraw WIDGET with current settings."
|
|
|
1611 (let ((line (count-lines (point-min) (point)))
|
|
|
1612 (column (current-column))
|
|
|
1613 (pos (point))
|
|
|
1614 (from (marker-position (widget-get widget :from)))
|
|
|
1615 (to (marker-position (widget-get widget :to))))
|
|
|
1616 (save-excursion
|
|
|
1617 (widget-value-set widget (widget-value widget))
|
|
|
1618 (custom-redraw-magic widget))
|
|
|
1619 (when (and (>= pos from) (<= pos to))
|
|
|
1620 (condition-case nil
|
|
|
1621 (progn
|
|
|
1622 (if (> column 0)
|
|
|
1623 (goto-line line)
|
|
|
1624 (goto-line (1+ line)))
|
|
|
1625 (move-to-column column))
|
|
|
1626 (error nil)))))
|
|
|
1627
|
|
|
1628 (defun custom-redraw-magic (widget)
|
|
|
1629 "Redraw WIDGET state with current settings."
|
|
|
1630 (while widget
|
|
|
1631 (let ((magic (widget-get widget :custom-magic)))
|
|
|
1632 (cond (magic
|
|
|
1633 (widget-value-set magic (widget-value magic))
|
|
|
1634 (when (setq widget (widget-get widget :group))
|
|
|
1635 (custom-group-state-update widget)))
|
|
|
1636 (t
|
|
|
1637 (setq widget nil)))))
|
|
|
1638 (widget-setup))
|
|
|
1639
|
|
|
1640 (defun custom-show (widget value)
|
|
|
1641 "Non-nil if WIDGET should be shown with VALUE by default."
|
|
|
1642 (let ((show (widget-get widget :custom-show)))
|
|
|
1643 (cond ((null show)
|
|
|
1644 nil)
|
|
|
1645 ((eq t show)
|
|
|
1646 t)
|
|
|
1647 (t
|
|
|
1648 (funcall show widget value)))))
|
|
|
1649
|
|
|
1650 (defvar custom-load-recursion nil
|
|
|
1651 "Hack to avoid recursive dependencies.")
|
|
|
1652
|
|
|
1653 (defun custom-load-symbol (symbol)
|
|
|
1654 "Load all dependencies for SYMBOL."
|
|
|
1655 (unless custom-load-recursion
|
|
|
1656 (let ((custom-load-recursion t)
|
|
|
1657 (loads (get symbol 'custom-loads))
|
|
|
1658 load)
|
|
|
1659 (while loads
|
|
|
1660 (setq load (car loads)
|
|
|
1661 loads (cdr loads))
|
|
2544
|
1662 (custom-load-symbol-1 load)))))
|
|
|
1663
|
|
|
1664 (defun custom-load-symbol-1 (load)
|
|
|
1665 (cond ((symbolp load)
|
|
|
1666 (condition-case nil
|
|
|
1667 (require load)
|
|
|
1668 (error nil)))
|
|
|
1669 ;; Don't reload a file already loaded.
|
|
|
1670 ((and (boundp 'preloaded-file-list)
|
|
|
1671 (member load preloaded-file-list)))
|
|
|
1672 ((assoc load load-history))
|
|
|
1673 ((assoc (locate-library load) load-history))
|
|
|
1674 (t
|
|
|
1675 (condition-case nil
|
|
|
1676 ;; Without this, we would load cus-edit recursively.
|
|
|
1677 ;; We are still loading it when we call this,
|
|
|
1678 ;; and it is not in load-history yet.
|
|
|
1679 (or (equal load "cus-edit")
|
|
|
1680 (load-library load))
|
|
|
1681 (error nil)))))
|
|
|
1682
|
|
|
1683 (defvar custom-already-loaded-custom-defines nil
|
|
|
1684 "List of already-loaded `custom-defines' files.")
|
|
|
1685 (defvar custom-define-current-source-file nil)
|
|
|
1686 (defvar custom-warn-when-reloading-necessary nil
|
|
|
1687 "For package-debugging purposes: Warn when an error hit in custom-defines.el.
|
|
|
1688 When this happens, the file from which the defcustom or defgroup was taken
|
|
|
1689 is loaded, and custom-defines.el is then reloaded. This works in most
|
|
|
1690 cases, but may not be completely safe. It's better if the package itself
|
|
|
1691 arranges for the necessary functions and variables to be available, using
|
|
|
1692 \;;;###autoload declarations. When this variable is non-nil, warnings are
|
|
|
1693 issued (with backtrace), to aid in tracking down the problems.")
|
|
|
1694
|
|
|
1695 (defun custom-load-custom-defines (symbol)
|
|
|
1696 "Load custom-defines for SYMBOL."
|
|
|
1697 (unless custom-load-recursion
|
|
|
1698 (let ((custom-load-recursion t)
|
|
|
1699 (loads (get symbol 'custom-loads))
|
|
|
1700 load)
|
|
|
1701 (while loads
|
|
|
1702 (setq load (car loads)
|
|
|
1703 loads (cdr loads))
|
|
|
1704 (let* ((found (locate-library
|
|
|
1705 (if (symbolp load) (symbol-name load) load)))
|
|
|
1706 (dir (and found (file-name-directory found))))
|
|
|
1707 ;; If we find a custom-defines file, assume the package is smart
|
|
|
1708 ;; enough to have put all its defcustoms and defgroups here, and
|
|
|
1709 ;; load it instead of the file itself. Otherwise, do it the
|
|
|
1710 ;; hard way.
|
|
|
1711 (if (and found (or (file-exists-p
|
|
|
1712 (expand-file-name "custom-defines.elc" dir))
|
|
|
1713 (file-exists-p
|
|
|
1714 (expand-file-name "custom-defines.el" dir))))
|
|
|
1715 (when (not (member dir custom-already-loaded-custom-defines))
|
|
|
1716 (push dir custom-already-loaded-custom-defines)
|
|
|
1717 (custom-load-custom-defines-1 dir))))))))
|
|
|
1718
|
|
|
1719 (defun custom-load-custom-defines-1 (dir)
|
|
|
1720 ;; Actually load the custom-defines.el file in DIR.
|
|
|
1721
|
|
|
1722 ;; If we get an error loading the custom-defines, it may be because of a
|
|
|
1723 ;; reference to something (e.g. a constant) that hasn't yet been defined
|
|
|
1724 ;; yet. Properly, these should have been marked, so they either go into
|
|
|
1725 ;; the custom-defines.el file or are autoloaded. But not everyone is so
|
|
|
1726 ;; careful, so for the moment we try to load the file that the
|
|
|
1727 ;; error-generating defcustom came from, and then reload the
|
|
|
1728 ;; custom-defines.el file. We might loop a number of times if we have
|
|
|
1729 ;; various files that need loading. If at any point we get an error that
|
|
|
1730 ;; can't be solved just by loading the appropriate file (e.g. we hit the
|
|
|
1731 ;; same error as before, the file is already loaded, etc.) then we signal
|
|
|
1732 ;; it as a real error.
|
|
|
1733 (let (source)
|
|
|
1734 ;; here's how this works: if we get an error loading custom-defines,
|
|
|
1735 ;; the condition handler is called; if we need to reload, we
|
|
|
1736 ;; `return-from', which throws out of the handler and returns nil from
|
|
|
1737 ;; the `block', which continues the while statement, executing the
|
|
|
1738 ;; `load' at the bottom of this function and then entering the block
|
|
|
1739 ;; again. if the condition handler doesn't throw, but instead returns
|
|
|
1740 ;; normally, `signal' will continue as if nothing happened, and end up
|
|
|
1741 ;; signalling the error normally.
|
|
|
1742 (while
|
|
|
1743 (not
|
|
|
1744 (block custom-load
|
|
|
1745 ;; Use call-with-condition-handler so the error can be seen
|
|
|
1746 ;; with the stack intact.
|
|
|
1747 (call-with-condition-handler
|
|
|
1748 #'(lambda (__custom_load_cd1__)
|
|
|
1749 (when (and
|
|
|
1750 custom-define-current-source-file
|
|
|
1751 (progn
|
|
|
1752 (setq source (expand-file-name
|
|
|
1753 custom-define-current-source-file
|
|
|
1754 dir))
|
|
|
1755 (let ((nondir (file-name-nondirectory source)))
|
|
|
1756 (and (file-exists-p source)
|
|
|
1757 (not (assoc source load-history))
|
|
|
1758 (not (assoc nondir load-history))
|
|
|
1759 (not (and (boundp 'preloaded-file-list)
|
|
|
1760 (member nondir
|
|
|
1761 preloaded-file-list)))))))
|
|
|
1762 (if custom-warn-when-reloading-necessary
|
|
|
1763 (lwarn 'custom-defines 'warning
|
|
|
1764 "Error while loading custom-defines, fetching source and reloading ...\n
|
|
|
1765 Error: %s\n
|
|
|
1766 Source file: %s\n\n
|
|
|
1767 Backtrace follows:\n\n%s"
|
|
|
1768 (error-message-string __custom_load_cd1__)
|
|
|
1769 source
|
|
|
1770 (backtrace-in-condition-handler-eliminating-handler
|
|
|
1771 '__custom_load_cd1__)))
|
|
|
1772 (return-from custom-load nil)))
|
|
|
1773 #'(lambda ()
|
|
|
1774 (load (expand-file-name "custom-defines" dir))))))
|
|
4178
|
1775 ;; we get here only from the `return-from'; see above
|
|
2544
|
1776 (load source))))
|
|
428
|
1777
|
|
|
1778 (defun custom-load-widget (widget)
|
|
|
1779 "Load all dependencies for WIDGET."
|
|
|
1780 (custom-load-symbol (widget-value widget)))
|
|
|
1781
|
|
|
1782 (defun custom-unloaded-symbol-p (symbol)
|
|
|
1783 "Return non-nil if the dependencies of SYMBOL has not yet been loaded."
|
|
|
1784 (let ((found nil)
|
|
|
1785 (loads (get symbol 'custom-loads))
|
|
|
1786 load)
|
|
|
1787 (while loads
|
|
|
1788 (setq load (car loads)
|
|
|
1789 loads (cdr loads))
|
|
|
1790 (cond ((symbolp load)
|
|
|
1791 (unless (featurep load)
|
|
|
1792 (setq found t)))
|
|
|
1793 ((assoc load load-history))
|
|
|
1794 ((assoc (locate-library load) load-history)
|
|
|
1795 ;; #### WTF???
|
|
|
1796 (message nil))
|
|
|
1797 (t
|
|
|
1798 (setq found t))))
|
|
|
1799 found))
|
|
|
1800
|
|
|
1801 (defun custom-unloaded-widget-p (widget)
|
|
|
1802 "Return non-nil if the dependencies of WIDGET has not yet been loaded."
|
|
|
1803 (custom-unloaded-symbol-p (widget-value widget)))
|
|
|
1804
|
|
|
1805 (defun custom-toggle-hide (widget)
|
|
|
1806 "Toggle visibility of WIDGET."
|
|
|
1807 (custom-load-widget widget)
|
|
|
1808 (let ((state (widget-get widget :custom-state)))
|
|
|
1809 (cond ((memq state '(invalid modified))
|
|
|
1810 (error "There are unset changes"))
|
|
|
1811 ((eq state 'hidden)
|
|
|
1812 (widget-put widget :custom-state 'unknown))
|
|
|
1813 (t
|
|
|
1814 (widget-put widget :documentation-shown nil)
|
|
|
1815 (widget-put widget :custom-state 'hidden)))
|
|
|
1816 (custom-redraw widget)
|
|
|
1817 (widget-setup)))
|
|
|
1818
|
|
|
1819 (defun custom-toggle-parent (widget &rest ignore)
|
|
|
1820 "Toggle visibility of parent of WIDGET."
|
|
|
1821 (custom-toggle-hide (widget-get widget :parent)))
|
|
|
1822
|
|
|
1823 (defun custom-add-see-also (widget &optional prefix)
|
|
|
1824 "Add `See also ...' to WIDGET if there are any links.
|
|
|
1825 Insert PREFIX first if non-nil."
|
|
|
1826 (let* ((symbol (widget-get widget :value))
|
|
|
1827 (links (get symbol 'custom-links))
|
|
|
1828 (many (> (length links) 2))
|
|
|
1829 (buttons (widget-get widget :buttons))
|
|
|
1830 (indent (widget-get widget :indent)))
|
|
|
1831 (when links
|
|
|
1832 (when indent
|
|
|
1833 (insert-char ?\ indent))
|
|
|
1834 (when prefix
|
|
|
1835 (insert prefix))
|
|
|
1836 (insert "See also ")
|
|
|
1837 (while links
|
|
|
1838 (push (widget-create-child-and-convert widget (car links))
|
|
|
1839 buttons)
|
|
|
1840 (setq links (cdr links))
|
|
|
1841 (cond ((null links)
|
|
|
1842 (insert ".\n"))
|
|
|
1843 ((null (cdr links))
|
|
|
1844 (if many
|
|
|
1845 (insert ", and ")
|
|
|
1846 (insert " and ")))
|
|
|
1847 (t
|
|
|
1848 (insert ", "))))
|
|
|
1849 (widget-put widget :buttons buttons))))
|
|
|
1850
|
|
|
1851 (defun custom-add-parent-links (widget &optional initial-string)
|
|
|
1852 "Add \"Parent groups: ...\" to WIDGET if the group has parents.
|
|
|
1853 The value if non-nil if any parents were found.
|
|
|
1854 If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
|
|
|
1855 (let ((name (widget-value widget))
|
|
|
1856 (type (widget-type widget))
|
|
|
1857 (buttons (widget-get widget :buttons))
|
|
|
1858 (start (point))
|
|
|
1859 found)
|
|
|
1860 (insert (or initial-string "Parent groups:"))
|
|
|
1861 (maphash (lambda (group ignore)
|
|
|
1862 (let ((entry (assq name (get group 'custom-group))))
|
|
|
1863 (when (eq (nth 1 entry) type)
|
|
|
1864 (insert " ")
|
|
|
1865 (push (widget-create-child-and-convert
|
|
|
1866 widget 'custom-group-link
|
|
|
1867 :tag (custom-unlispify-tag-name group)
|
|
|
1868 group)
|
|
|
1869 buttons)
|
|
|
1870 (setq found t))))
|
|
|
1871 custom-group-hash-table)
|
|
|
1872 (widget-put widget :buttons buttons)
|
|
|
1873 (if found
|
|
|
1874 (insert "\n")
|
|
|
1875 (delete-region start (point)))
|
|
|
1876 found))
|
|
|
1877
|
|
|
1878 ;;; The `custom-comment' Widget.
|
|
|
1879
|
|
|
1880 ;; like the editable field
|
|
|
1881 (defface custom-comment-face '((((class grayscale color)
|
|
|
1882 (background light))
|
|
|
1883 (:background "gray85"))
|
|
|
1884 (((class grayscale color)
|
|
|
1885 (background dark))
|
|
|
1886 (:background "dim gray"))
|
|
|
1887 (t
|
|
|
1888 (:italic t)))
|
|
|
1889 "Face used for comments on variables or faces"
|
|
|
1890 :group 'custom-faces)
|
|
|
1891
|
|
|
1892 ;; like font-lock-comment-face
|
|
|
1893 (defface custom-comment-tag-face
|
|
|
1894 '((((class color) (background dark)) (:foreground "gray80"))
|
|
|
1895 (((class color) (background light)) (:foreground "blue4"))
|
|
|
1896 (((class grayscale) (background light))
|
|
|
1897 (:foreground "DimGray" :bold t :italic t))
|
|
|
1898 (((class grayscale) (background dark))
|
|
|
1899 (:foreground "LightGray" :bold t :italic t))
|
|
|
1900 (t (:bold t)))
|
|
|
1901 "Face used for variables or faces comment tags"
|
|
|
1902 :group 'custom-faces)
|
|
|
1903
|
|
|
1904 (define-widget 'custom-comment 'string
|
|
|
1905 "User comment"
|
|
|
1906 :tag "Comment"
|
|
|
1907 :help-echo "Edit a comment here"
|
|
|
1908 :sample-face 'custom-comment-tag-face
|
|
|
1909 :value-face 'custom-comment-face
|
|
|
1910 :value-set 'custom-comment-value-set
|
|
|
1911 :create 'custom-comment-create
|
|
|
1912 :delete 'custom-comment-delete)
|
|
|
1913
|
|
|
1914 (defun custom-comment-create (widget)
|
|
|
1915 (let (ext)
|
|
|
1916 (widget-default-create widget)
|
|
|
1917 (widget-put widget :comment-extent
|
|
|
1918 (setq ext (make-extent (widget-get widget :from)
|
|
|
1919 (widget-get widget :to))))
|
|
|
1920 (set-extent-property ext 'start-open t)
|
|
|
1921 (when (equal (widget-get widget :value) "")
|
|
|
1922 (set-extent-property ext 'invisible t))
|
|
|
1923 ))
|
|
|
1924
|
|
|
1925 (defun custom-comment-delete (widget)
|
|
|
1926 (widget-default-delete widget)
|
|
|
1927 (delete-extent (widget-get widget :comment-extent)))
|
|
|
1928
|
|
|
1929 (defun custom-comment-value-set (widget value)
|
|
|
1930 (widget-default-value-set widget value)
|
|
|
1931 (if (equal value "")
|
|
|
1932 (set-extent-property (widget-get widget :comment-extent)
|
|
|
1933 'invisible t)
|
|
|
1934 (set-extent-property (widget-get widget :comment-extent)
|
|
|
1935 'invisible nil)))
|
|
|
1936
|
|
|
1937 ;; Those functions are for the menu. WIDGET is NOT the comment widget. It's
|
|
|
1938 ;; the global custom one
|
|
|
1939 (defun custom-comment-show (widget)
|
|
|
1940 (set-extent-property
|
|
|
1941 (widget-get (widget-get widget :comment-widget) :comment-extent)
|
|
|
1942 'invisible nil))
|
|
|
1943
|
|
|
1944 (defun custom-comment-invisible-p (widget)
|
|
|
1945 (extent-property
|
|
|
1946 (widget-get (widget-get widget :comment-widget) :comment-extent)
|
|
|
1947 'invisible))
|
|
|
1948
|
|
|
1949 ;;; The `custom-variable' Widget.
|
|
|
1950
|
|
|
1951 (defface custom-variable-tag-face '((((class color)
|
|
|
1952 (background dark))
|
|
|
1953 (:foreground "light blue" :underline t))
|
|
|
1954 (((class color)
|
|
|
1955 (background light))
|
|
|
1956 (:foreground "blue" :underline t))
|
|
|
1957 (t (:underline t)))
|
|
|
1958 "Face used for unpushable variable tags."
|
|
|
1959 :group 'custom-faces)
|
|
|
1960
|
|
|
1961 (defface custom-variable-button-face '((t (:underline t :bold t)))
|
|
|
1962 "Face used for pushable variable tags."
|
|
|
1963 :group 'custom-faces)
|
|
|
1964
|
|
|
1965 (defcustom custom-variable-default-form 'edit
|
|
|
1966 "Default form of displaying variable values."
|
|
|
1967 :type '(choice (const edit)
|
|
|
1968 (const lisp))
|
|
|
1969 :group 'custom-buffer)
|
|
|
1970
|
|
|
1971 (define-widget 'custom-variable 'custom
|
|
|
1972 "Customize variable."
|
|
|
1973 :format "%v"
|
|
|
1974 :help-echo "Set or reset this variable"
|
|
|
1975 :documentation-property 'variable-documentation
|
|
|
1976 :custom-category 'option
|
|
|
1977 :custom-state nil
|
|
|
1978 :custom-menu 'custom-variable-menu-create
|
|
|
1979 :custom-form nil ; defaults to value of `custom-variable-default-form'
|
|
|
1980 :value-create 'custom-variable-value-create
|
|
|
1981 :action 'custom-variable-action
|
|
|
1982 :custom-set 'custom-variable-set
|
|
480
|
1983 :custom-pre-save 'custom-variable-pre-save
|
|
428
|
1984 :custom-save 'custom-variable-save
|
|
480
|
1985 :custom-post-save 'custom-variable-post-save
|
|
428
|
1986 :custom-reset-current 'custom-redraw
|
|
|
1987 :custom-reset-saved 'custom-variable-reset-saved
|
|
480
|
1988 :custom-pre-reset-standard 'custom-variable-pre-reset-standard
|
|
|
1989 :custom-reset-standard 'custom-variable-reset-standard
|
|
|
1990 :custom-post-reset-standard 'custom-variable-post-reset-standard)
|
|
428
|
1991
|
|
|
1992 (defun custom-variable-type (symbol)
|
|
|
1993 "Return a widget suitable for editing the value of SYMBOL.
|
|
|
1994 If SYMBOL has a `custom-type' property, use that.
|
|
|
1995 Otherwise, look up symbol in `custom-guess-type-alist'."
|
|
|
1996 (let* ((type (or (get symbol 'custom-type)
|
|
|
1997 (and (not (get symbol 'standard-value))
|
|
|
1998 (custom-guess-type symbol))
|
|
|
1999 'sexp))
|
|
|
2000 (options (get symbol 'custom-options))
|
|
|
2001 (tmp (if (listp type)
|
|
|
2002 (copy-sequence type)
|
|
|
2003 (list type))))
|
|
|
2004 (when options
|
|
|
2005 (widget-put tmp :options options))
|
|
|
2006 tmp))
|
|
|
2007
|
|
|
2008 (defun custom-variable-value-create (widget)
|
|
|
2009 "Here is where you edit the variables value."
|
|
|
2010 (custom-load-widget widget)
|
|
|
2011 (unless (widget-get widget :custom-form)
|
|
|
2012 (widget-put widget :custom-form custom-variable-default-form))
|
|
|
2013 (let* ((buttons (widget-get widget :buttons))
|
|
|
2014 (children (widget-get widget :children))
|
|
|
2015 (form (widget-get widget :custom-form))
|
|
|
2016 (state (widget-get widget :custom-state))
|
|
|
2017 (symbol (widget-get widget :value))
|
|
|
2018 (tag (widget-get widget :tag))
|
|
|
2019 (type (custom-variable-type symbol))
|
|
|
2020 (conv (widget-convert type))
|
|
|
2021 (get (or (get symbol 'custom-get) 'default-value))
|
|
|
2022 (prefix (widget-get widget :custom-prefix))
|
|
|
2023 (last (widget-get widget :custom-last))
|
|
|
2024 (value (if (default-boundp symbol)
|
|
|
2025 (funcall get symbol)
|
|
|
2026 (widget-get conv :value))))
|
|
|
2027 ;; If the widget is new, the child determine whether it is hidden.
|
|
|
2028 (cond (state)
|
|
|
2029 ((custom-show type value)
|
|
|
2030 (setq state 'unknown))
|
|
|
2031 (t
|
|
|
2032 (setq state 'hidden)))
|
|
|
2033 ;; If we don't know the state, see if we need to edit it in lisp form.
|
|
|
2034 (when (eq state 'unknown)
|
|
|
2035 (unless (widget-apply conv :match value)
|
|
|
2036 ;; (widget-apply (widget-convert type) :match value)
|
|
|
2037 (setq form 'mismatch)))
|
|
|
2038 ;; Now we can create the child widget.
|
|
|
2039 (cond ((eq custom-buffer-style 'tree)
|
|
|
2040 (insert prefix (if last " `--- " " |--- "))
|
|
|
2041 (push (widget-create-child-and-convert
|
|
|
2042 widget 'custom-browse-variable-tag)
|
|
|
2043 buttons)
|
|
|
2044 (insert " " tag "\n")
|
|
|
2045 (widget-put widget :buttons buttons))
|
|
|
2046 ((eq state 'hidden)
|
|
|
2047 ;; Indicate hidden value.
|
|
|
2048 (push (widget-create-child-and-convert
|
|
|
2049 widget 'item
|
|
|
2050 :format "%{%t%}: "
|
|
|
2051 :sample-face 'custom-variable-tag-face
|
|
|
2052 :tag tag
|
|
|
2053 :parent widget)
|
|
|
2054 buttons)
|
|
|
2055 (push (widget-create-child-and-convert
|
|
|
2056 widget 'visibility
|
|
|
2057 :help-echo "Show the value of this option"
|
|
|
2058 :action 'custom-toggle-parent
|
|
|
2059 nil)
|
|
|
2060 buttons))
|
|
|
2061 ((memq form '(lisp mismatch))
|
|
|
2062 ;; In lisp mode edit the saved value when possible.
|
|
|
2063 (let* ((value (cond ((get symbol 'saved-value)
|
|
|
2064 (car (get symbol 'saved-value)))
|
|
|
2065 ((get symbol 'standard-value)
|
|
|
2066 (car (get symbol 'standard-value)))
|
|
|
2067 ((default-boundp symbol)
|
|
|
2068 (custom-quote (funcall get symbol)))
|
|
|
2069 (t
|
|
|
2070 (custom-quote (widget-get conv :value))))))
|
|
|
2071 (insert (symbol-name symbol) ": ")
|
|
|
2072 (push (widget-create-child-and-convert
|
|
|
2073 widget 'visibility
|
|
|
2074 :help-echo "Hide the value of this option"
|
|
|
2075 :action 'custom-toggle-parent
|
|
|
2076 t)
|
|
|
2077 buttons)
|
|
|
2078 (insert " ")
|
|
|
2079 (push (widget-create-child-and-convert
|
|
|
2080 widget 'sexp
|
|
|
2081 :button-face 'custom-variable-button-face
|
|
|
2082 :format "%v"
|
|
|
2083 :tag (symbol-name symbol)
|
|
|
2084 :parent widget
|
|
|
2085 :value value)
|
|
|
2086 children)))
|
|
|
2087 (t
|
|
|
2088 ;; Edit mode.
|
|
|
2089 (let* ((format (widget-get type :format))
|
|
|
2090 tag-format value-format)
|
|
|
2091 (while (not (string-match ":" format))
|
|
|
2092 (setq format (signal 'error (list "Bad format" format))))
|
|
|
2093 (setq tag-format (substring format 0 (match-end 0)))
|
|
|
2094 (setq value-format (substring format (match-end 0)))
|
|
|
2095 (push (widget-create-child-and-convert
|
|
|
2096 widget 'item
|
|
|
2097 :format tag-format
|
|
|
2098 :action 'custom-tag-action
|
|
|
2099 :help-echo "Change value of this option"
|
|
|
2100 :mouse-down-action 'custom-tag-mouse-down-action
|
|
|
2101 :button-face 'custom-variable-button-face
|
|
|
2102 :sample-face 'custom-variable-tag-face
|
|
|
2103 tag)
|
|
|
2104 buttons)
|
|
|
2105 (insert " ")
|
|
|
2106 (push (widget-create-child-and-convert
|
|
|
2107 widget 'visibility
|
|
|
2108 :help-echo "Hide the value of this option"
|
|
|
2109 :action 'custom-toggle-parent
|
|
|
2110 t)
|
|
|
2111 buttons)
|
|
|
2112 (push (widget-create-child-and-convert
|
|
|
2113 widget type
|
|
|
2114 :format value-format
|
|
|
2115 :value value)
|
|
|
2116 children))))
|
|
|
2117 (unless (eq custom-buffer-style 'tree)
|
|
|
2118 (unless (eq (preceding-char) ?\n)
|
|
|
2119 (widget-insert "\n"))
|
|
|
2120 ;; Create the magic button.
|
|
|
2121 (let ((magic (widget-create-child-and-convert
|
|
|
2122 widget 'custom-magic nil)))
|
|
|
2123 (widget-put widget :custom-magic magic)
|
|
|
2124 (push magic buttons))
|
|
|
2125 ;; Insert documentation.
|
|
440
|
2126 ;; #### NOTE: this is ugly!!!! I need to do update the :buttons property
|
|
428
|
2127 ;; before the call to `widget-default-format-handler'. Otherwise, I
|
|
444
|
2128 ;; lose my current `buttons'. This function shouldn't be called like
|
|
428
|
2129 ;; this anyway. The doc string widget should be added like the others.
|
|
|
2130 ;; --dv
|
|
|
2131 (widget-put widget :buttons buttons)
|
|
|
2132 (widget-default-format-handler widget ?h)
|
|
|
2133 ;; The comment field
|
|
|
2134 (unless (eq state 'hidden)
|
|
|
2135 (let* ((comment (get symbol 'variable-comment))
|
|
|
2136 (comment-widget
|
|
|
2137 (widget-create-child-and-convert
|
|
|
2138 widget 'custom-comment
|
|
|
2139 :parent widget
|
|
|
2140 :value (or comment ""))))
|
|
|
2141 (widget-put widget :comment-widget comment-widget)
|
|
|
2142 ;; Don't push it !!! Custom assumes that the first child is the
|
|
|
2143 ;; value one.
|
|
|
2144 (setq children (append children (list comment-widget)))))
|
|
2118
|
2145 ;; Update the rest of the properties.
|
|
428
|
2146 (widget-put widget :custom-form form)
|
|
|
2147 (widget-put widget :children children)
|
|
|
2148 ;; Now update the state.
|
|
|
2149 (if (eq state 'hidden)
|
|
|
2150 (widget-put widget :custom-state state)
|
|
|
2151 (custom-variable-state-set widget))
|
|
|
2152 ;; See also.
|
|
|
2153 (unless (eq state 'hidden)
|
|
|
2154 (when (eq (widget-get widget :custom-level) 1)
|
|
|
2155 (custom-add-parent-links widget))
|
|
|
2156 (custom-add-see-also widget)))))
|
|
|
2157
|
|
|
2158 (defun custom-tag-action (widget &rest args)
|
|
|
2159 "Pass :action to first child of WIDGET's parent."
|
|
|
2160 (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
|
|
|
2161 :action args))
|
|
|
2162
|
|
|
2163 (defun custom-tag-mouse-down-action (widget &rest args)
|
|
|
2164 "Pass :mouse-down-action to first child of WIDGET's parent."
|
|
|
2165 (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
|
|
|
2166 :mouse-down-action args))
|
|
|
2167
|
|
|
2168 (defun custom-variable-state-set (widget)
|
|
|
2169 "Set the state of WIDGET."
|
|
|
2170 (let* ((symbol (widget-value widget))
|
|
|
2171 (get (or (get symbol 'custom-get) 'default-value))
|
|
|
2172 (value (if (default-boundp symbol)
|
|
|
2173 (funcall get symbol)
|
|
|
2174 (widget-get widget :value)))
|
|
|
2175 (comment (get symbol 'variable-comment))
|
|
|
2176 tmp
|
|
|
2177 temp
|
|
|
2178 (state (cond ((progn (setq tmp (get symbol 'customized-value))
|
|
|
2179 (setq temp
|
|
|
2180 (get symbol 'customized-variable-comment))
|
|
|
2181 (or tmp temp))
|
|
|
2182 (if (condition-case nil
|
|
|
2183 (and (equal value (eval (car tmp)))
|
|
|
2184 (equal comment temp))
|
|
|
2185 (error nil))
|
|
|
2186 'set
|
|
|
2187 'changed))
|
|
|
2188 ((progn (setq tmp (get symbol 'saved-value))
|
|
|
2189 (setq temp (get symbol 'saved-variable-comment))
|
|
|
2190 (or tmp temp))
|
|
|
2191 (if (condition-case nil
|
|
|
2192 (and (equal value (eval (car tmp)))
|
|
|
2193 (equal comment temp))
|
|
|
2194 (error nil))
|
|
|
2195 'saved
|
|
|
2196 'changed))
|
|
|
2197 ((setq tmp (get symbol 'standard-value))
|
|
|
2198 (if (condition-case nil
|
|
|
2199 (and (equal value (eval (car tmp)))
|
|
|
2200 (equal comment nil))
|
|
|
2201 (error nil))
|
|
|
2202 'standard
|
|
|
2203 'changed))
|
|
|
2204 (t 'rogue))))
|
|
|
2205 (widget-put widget :custom-state state)))
|
|
|
2206
|
|
|
2207 (defvar custom-variable-menu
|
|
4289
|
2208 `(("Set for Current Session" custom-variable-set
|
|
|
2209 ,#'(lambda (widget)
|
|
|
2210 (eq (widget-get widget :custom-state) 'modified)))
|
|
428
|
2211 ("Save for Future Sessions" custom-variable-save
|
|
4289
|
2212 ,#'(lambda (widget)
|
|
|
2213 (memq (widget-get widget :custom-state)
|
|
|
2214 '(modified set changed rogue))))
|
|
428
|
2215 ("Reset to Current" custom-redraw
|
|
4289
|
2216 ,#'(lambda (widget)
|
|
|
2217 (and (default-boundp (widget-value widget))
|
|
|
2218 (memq (widget-get widget :custom-state) '(modified changed)))))
|
|
428
|
2219 ("Reset to Saved" custom-variable-reset-saved
|
|
4289
|
2220 ,#'(lambda (widget)
|
|
|
2221 (and (or (get (widget-value widget) 'saved-value)
|
|
|
2222 (get (widget-value widget) 'saved-variable-comment))
|
|
|
2223 (memq (widget-get widget :custom-state)
|
|
|
2224 '(modified set changed rogue)))))
|
|
428
|
2225 ("Reset to Standard Settings" custom-variable-reset-standard
|
|
4289
|
2226 ,#'(lambda (widget)
|
|
|
2227 (and (get (widget-value widget) 'standard-value)
|
|
|
2228 (memq (widget-get widget :custom-state)
|
|
|
2229 '(modified set changed saved rogue)))))
|
|
428
|
2230 ("---" ignore ignore)
|
|
|
2231 ("Add Comment" custom-comment-show custom-comment-invisible-p)
|
|
|
2232 ("---" ignore ignore)
|
|
|
2233 ("Don't show as Lisp expression" custom-variable-edit
|
|
4289
|
2234 ,#'(lambda (widget)
|
|
|
2235 (eq (widget-get widget :custom-form) 'lisp)))
|
|
428
|
2236 ("Show as Lisp expression" custom-variable-edit-lisp
|
|
4289
|
2237 ,#'(lambda (widget)
|
|
|
2238 (eq (widget-get widget :custom-form) 'edit))))
|
|
428
|
2239 "Alist of actions for the `custom-variable' widget.
|
|
|
2240 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
|
|
|
2241 the menu entry, ACTION is the function to call on the widget when the
|
|
|
2242 menu is selected, and FILTER is a predicate which takes a `custom-variable'
|
|
|
2243 widget as an argument, and returns non-nil if ACTION is valid on that
|
|
|
2244 widget. If FILTER is nil, ACTION is always valid.")
|
|
|
2245
|
|
|
2246 (defun custom-variable-action (widget &optional event)
|
|
|
2247 "Show the menu for `custom-variable' WIDGET.
|
|
|
2248 Optional EVENT is the location for the menu."
|
|
|
2249 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
|
2250 (custom-toggle-hide widget)
|
|
|
2251 (unless (eq (widget-get widget :custom-state) 'modified)
|
|
|
2252 (custom-variable-state-set widget))
|
|
|
2253 ;; Redrawing magic also depresses the state glyph.
|
|
|
2254 ;(custom-redraw-magic widget)
|
|
|
2255 (let* ((completion-ignore-case t)
|
|
|
2256 (answer (widget-choose (concat "Operation on "
|
|
|
2257 (custom-unlispify-tag-name
|
|
|
2258 (widget-get widget :value)))
|
|
|
2259 (custom-menu-filter custom-variable-menu
|
|
|
2260 widget)
|
|
|
2261 event)))
|
|
|
2262 (if answer
|
|
|
2263 (funcall answer widget)))))
|
|
|
2264
|
|
|
2265 (defun custom-variable-edit (widget)
|
|
|
2266 "Edit value of WIDGET."
|
|
|
2267 (widget-put widget :custom-state 'unknown)
|
|
|
2268 (widget-put widget :custom-form 'edit)
|
|
|
2269 (custom-redraw widget))
|
|
|
2270
|
|
|
2271 (defun custom-variable-edit-lisp (widget)
|
|
|
2272 "Edit the lisp representation of the value of WIDGET."
|
|
|
2273 (widget-put widget :custom-state 'unknown)
|
|
|
2274 (widget-put widget :custom-form 'lisp)
|
|
|
2275 (custom-redraw widget))
|
|
|
2276
|
|
|
2277 (defun custom-variable-set (widget)
|
|
|
2278 "Set the current value for the variable being edited by WIDGET."
|
|
|
2279 (let* ((form (widget-get widget :custom-form))
|
|
|
2280 (state (widget-get widget :custom-state))
|
|
|
2281 (child (car (widget-get widget :children)))
|
|
|
2282 (symbol (widget-value widget))
|
|
|
2283 (set (or (get symbol 'custom-set) 'set-default))
|
|
|
2284 (comment-widget (widget-get widget :comment-widget))
|
|
|
2285 (comment (widget-value comment-widget))
|
|
|
2286 val)
|
|
|
2287 (cond ((eq state 'hidden)
|
|
|
2288 (error "Cannot set hidden variable"))
|
|
|
2289 ((setq val (widget-apply child :validate))
|
|
|
2290 (goto-char (widget-get val :from))
|
|
|
2291 (error "%s" (widget-get val :error)))
|
|
|
2292 ((memq form '(lisp mismatch))
|
|
|
2293 (when (equal comment "")
|
|
|
2294 (setq comment nil)
|
|
|
2295 ;; Make the comment invisible by hand if it's empty
|
|
|
2296 (set-extent-property (widget-get comment-widget :comment-extent)
|
|
|
2297 'invisible t))
|
|
|
2298 (funcall set symbol (eval (setq val (widget-value child))))
|
|
|
2299 (put symbol 'customized-value (list val))
|
|
|
2300 (put symbol 'variable-comment comment)
|
|
|
2301 (put symbol 'customized-variable-comment comment))
|
|
|
2302 (t
|
|
|
2303 (when (equal comment "")
|
|
|
2304 (setq comment nil)
|
|
|
2305 ;; Make the comment invisible by hand if it's empty
|
|
|
2306 (set-extent-property (widget-get comment-widget :comment-extent)
|
|
|
2307 'invisible t))
|
|
|
2308 (funcall set symbol (setq val (widget-value child)))
|
|
|
2309 (put symbol 'customized-value (list (custom-quote val)))
|
|
|
2310 (put symbol 'variable-comment comment)
|
|
|
2311 (put symbol 'customized-variable-comment comment)))
|
|
|
2312 (custom-variable-state-set widget)
|
|
|
2313 (custom-redraw-magic widget)))
|
|
|
2314
|
|
480
|
2315 (defun custom-variable-pre-save (widget)
|
|
|
2316 "Prepare for saving the value for the variable being edited by WIDGET."
|
|
428
|
2317 (let* ((form (widget-get widget :custom-form))
|
|
|
2318 (state (widget-get widget :custom-state))
|
|
|
2319 (child (car (widget-get widget :children)))
|
|
|
2320 (symbol (widget-value widget))
|
|
|
2321 (set (or (get symbol 'custom-set) 'set-default))
|
|
|
2322 (comment-widget (widget-get widget :comment-widget))
|
|
|
2323 (comment (widget-value comment-widget))
|
|
|
2324 val)
|
|
|
2325 (cond ((eq state 'hidden)
|
|
|
2326 (error "Cannot set hidden variable"))
|
|
|
2327 ((setq val (widget-apply child :validate))
|
|
|
2328 (goto-char (widget-get val :from))
|
|
|
2329 (error "%s" (widget-get val :error)))
|
|
|
2330 ((memq form '(lisp mismatch))
|
|
|
2331 (when (equal comment "")
|
|
|
2332 (setq comment nil)
|
|
|
2333 ;; Make the comment invisible by hand if it's empty
|
|
|
2334 (set-extent-property (widget-get comment-widget :comment-extent)
|
|
|
2335 'invisible t))
|
|
|
2336 (put symbol 'saved-value (list (widget-value child)))
|
|
|
2337 (custom-push-theme 'theme-value symbol 'user
|
|
|
2338 'set (list (widget-value child)))
|
|
|
2339 (funcall set symbol (eval (widget-value child)))
|
|
|
2340 (put symbol 'variable-comment comment)
|
|
|
2341 (put symbol 'saved-variable-comment comment))
|
|
|
2342 (t
|
|
|
2343 (when (equal comment "")
|
|
|
2344 (setq comment nil)
|
|
|
2345 ;; Make the comment invisible by hand if it's empty
|
|
|
2346 (set-extent-property (widget-get comment-widget :comment-extent)
|
|
|
2347 'invisible t))
|
|
|
2348 (put symbol
|
|
|
2349 'saved-value (list (custom-quote (widget-value
|
|
|
2350 child))))
|
|
|
2351 (custom-push-theme 'theme-value symbol 'user
|
|
|
2352 'set (list (custom-quote (widget-value
|
|
480
|
2353 child))))
|
|
428
|
2354 (funcall set symbol (widget-value child))
|
|
|
2355 (put symbol 'variable-comment comment)
|
|
|
2356 (put symbol 'saved-variable-comment comment)))
|
|
|
2357 (put symbol 'customized-value nil)
|
|
|
2358 (put symbol 'customized-variable-comment nil)
|
|
480
|
2359 ))
|
|
|
2360
|
|
|
2361 (defun custom-variable-post-save (widget)
|
|
|
2362 "Finish saving the variable being edited by WIDGET."
|
|
|
2363 (custom-variable-state-set widget)
|
|
|
2364 (custom-redraw-magic widget))
|
|
|
2365
|
|
|
2366 (defun custom-variable-save (widget)
|
|
|
2367 "Set and save the value for the variable being edited by WIDGET."
|
|
|
2368 (custom-variable-pre-save widget)
|
|
|
2369 (custom-save-all)
|
|
|
2370 (custom-variable-post-save widget))
|
|
428
|
2371
|
|
|
2372 (defun custom-variable-reset-saved (widget)
|
|
|
2373 "Restore the saved value for the variable being edited by WIDGET."
|
|
|
2374 (let* ((symbol (widget-value widget))
|
|
|
2375 (set (or (get symbol 'custom-set) 'set-default))
|
|
|
2376 (value (get symbol 'saved-value))
|
|
|
2377 (comment (get symbol 'saved-variable-comment)))
|
|
|
2378 (cond ((or value comment)
|
|
|
2379 (put symbol 'variable-comment comment)
|
|
|
2380 (condition-case nil
|
|
|
2381 (funcall set symbol (eval (car value)))
|
|
|
2382 (error nil)))
|
|
|
2383 (t
|
|
|
2384 (signal 'error (list "No saved value for variable" symbol))))
|
|
|
2385 (put symbol 'customized-value nil)
|
|
|
2386 (put symbol 'customized-variable-comment nil)
|
|
|
2387 (widget-put widget :custom-state 'unknown)
|
|
|
2388 ;; This call will possibly make the comment invisible
|
|
|
2389 (custom-redraw widget)))
|
|
|
2390
|
|
480
|
2391 ;; This function returns non nil if we need to re-save the options --dv.
|
|
|
2392 (defun custom-variable-pre-reset-standard (widget)
|
|
|
2393 "Prepare for restoring the variable being edited by WIDGET to its
|
|
|
2394 standard setting."
|
|
428
|
2395 (let* ((symbol (widget-value widget))
|
|
442
|
2396 (set (or (get symbol 'custom-set) 'set-default)))
|
|
428
|
2397 (if (get symbol 'standard-value)
|
|
|
2398 (funcall set symbol (eval (car (get symbol 'standard-value))))
|
|
|
2399 (signal 'error (list "No standard setting known for variable" symbol)))
|
|
|
2400 (put symbol 'variable-comment nil)
|
|
|
2401 (put symbol 'customized-value nil)
|
|
|
2402 (put symbol 'customized-variable-comment nil)
|
|
|
2403 (when (or (get symbol 'saved-value) (get symbol 'saved-variable-comment))
|
|
|
2404 (put symbol 'saved-value nil)
|
|
|
2405 (custom-push-theme 'theme-value symbol 'user 'reset 'standard)
|
|
|
2406 ;; As a special optimizations we do not (explictly)
|
|
480
|
2407 ;; save resets to standard when no theme sets the value.
|
|
428
|
2408 (if (null (cdr (get symbol 'theme-value)))
|
|
|
2409 (put symbol 'theme-value nil))
|
|
|
2410 (put symbol 'saved-variable-comment nil)
|
|
480
|
2411 widget)
|
|
|
2412 ))
|
|
|
2413
|
|
|
2414 (defun custom-variable-post-reset-standard (widget)
|
|
|
2415 "Finish resetting the variable being edited by WIDGET to its standard
|
|
|
2416 value."
|
|
|
2417 (widget-put widget :custom-state 'unknown)
|
|
|
2418 ;; This call will possibly make the comment invisible
|
|
|
2419 (custom-redraw widget))
|
|
|
2420
|
|
|
2421 (defun custom-variable-reset-standard (widget)
|
|
|
2422 "Restore the standard setting for the variable being edited by WIDGET."
|
|
|
2423 (when (custom-variable-pre-reset-standard widget)
|
|
|
2424 (custom-save-all))
|
|
|
2425 (custom-variable-post-reset-standard widget))
|
|
|
2426
|
|
428
|
2427
|
|
|
2428 ;;; The `custom-face-edit' Widget.
|
|
|
2429
|
|
|
2430 (define-widget 'custom-face-edit 'checklist
|
|
|
2431 "Edit face attributes."
|
|
|
2432 :format "%t: %v"
|
|
|
2433 :tag "Attributes"
|
|
|
2434 :extra-offset 12
|
|
438
|
2435 :button-args '(:help-echo "Control whether this attribute has any effect")
|
|
428
|
2436 :args (mapcar (lambda (att)
|
|
|
2437 (list 'group
|
|
|
2438 :inline t
|
|
|
2439 :sibling-args (widget-get (nth 1 att) :sibling-args)
|
|
|
2440 (list 'const :format "" :value (nth 0 att))
|
|
|
2441 (nth 1 att)))
|
|
|
2442 custom-face-attributes))
|
|
|
2443
|
|
|
2444 ;;; The `custom-display' Widget.
|
|
|
2445
|
|
|
2446 (define-widget 'custom-display 'menu-choice
|
|
|
2447 "Select a display type."
|
|
|
2448 :tag "Display"
|
|
|
2449 :value t
|
|
|
2450 :help-echo "Specify frames where the face attributes should be used"
|
|
|
2451 :args '((const :tag "all" t)
|
|
|
2452 (checklist
|
|
|
2453 :offset 0
|
|
|
2454 :extra-offset 9
|
|
|
2455 :args ((group :sibling-args (:help-echo "\
|
|
|
2456 Only match the specified window systems")
|
|
|
2457 (const :format "Type: "
|
|
|
2458 type)
|
|
|
2459 (checklist :inline t
|
|
|
2460 :offset 0
|
|
|
2461 (const :format "X "
|
|
|
2462 :sibling-args (:help-echo "\
|
|
|
2463 The X11 Window System")
|
|
|
2464 x)
|
|
555
|
2465 (const :format "GTK "
|
|
|
2466 :sibling-args (:help-echo "\
|
|
|
2467 The GTK Window System")
|
|
|
2468 gtk)
|
|
428
|
2469 (const :format "PM "
|
|
|
2470 :sibling-args (:help-echo "\
|
|
|
2471 OS/2 Presentation Manager")
|
|
|
2472 pm)
|
|
|
2473 (const :format "MSWindows "
|
|
|
2474 :sibling-args (:help-echo "\
|
|
440
|
2475 Microsoft Windows, displays")
|
|
428
|
2476 mswindows)
|
|
440
|
2477 (const :format "MSPrinter "
|
|
428
|
2478 :sibling-args (:help-echo "\
|
|
440
|
2479 Microsoft Windows, printers")
|
|
|
2480 msprinter)
|
|
428
|
2481 (const :format "TTY%n"
|
|
|
2482 :sibling-args (:help-echo "\
|
|
|
2483 Plain text terminals")
|
|
|
2484 tty)))
|
|
|
2485 (group :sibling-args (:help-echo "\
|
|
440
|
2486 Only match display or printer devices")
|
|
|
2487 (const :format "Output: "
|
|
|
2488 class)
|
|
|
2489 (checklist :inline t
|
|
|
2490 :offset 0
|
|
|
2491 (const :format "Display "
|
|
|
2492 :sibling-args (:help-echo "\
|
|
|
2493 Match display devices")
|
|
|
2494 display)
|
|
|
2495 (const :format "Printer%n"
|
|
|
2496 :sibling-args (:help-echo "\
|
|
|
2497 Match printer devices")
|
|
|
2498 printer)))
|
|
|
2499 (group :sibling-args (:help-echo "\
|
|
428
|
2500 Only match the frames with the specified color support")
|
|
440
|
2501 (const :format "Color support: "
|
|
428
|
2502 class)
|
|
|
2503 (checklist :inline t
|
|
|
2504 :offset 0
|
|
|
2505 (const :format "Color "
|
|
|
2506 :sibling-args (:help-echo "\
|
|
|
2507 Match color frames")
|
|
|
2508 color)
|
|
|
2509 (const :format "Grayscale "
|
|
|
2510 :sibling-args (:help-echo "\
|
|
|
2511 Match grayscale frames")
|
|
|
2512 grayscale)
|
|
|
2513 (const :format "Monochrome%n"
|
|
|
2514 :sibling-args (:help-echo "\
|
|
|
2515 Match frames with no color support")
|
|
|
2516 mono)))
|
|
|
2517 (group :sibling-args (:help-echo "\
|
|
|
2518 Only match frames with the specified intensity")
|
|
|
2519 (const :format "\
|
|
|
2520 Background brightness: "
|
|
|
2521 background)
|
|
|
2522 (checklist :inline t
|
|
|
2523 :offset 0
|
|
|
2524 (const :format "Light "
|
|
|
2525 :sibling-args (:help-echo "\
|
|
|
2526 Match frames with light backgrounds")
|
|
|
2527 light)
|
|
|
2528 (const :format "Dark\n"
|
|
|
2529 :sibling-args (:help-echo "\
|
|
|
2530 Match frames with dark backgrounds")
|
|
|
2531 dark)))))))
|
|
|
2532
|
|
|
2533 ;;; The `custom-face' Widget.
|
|
|
2534
|
|
|
2535 (defface custom-face-tag-face '((t (:underline t)))
|
|
|
2536 "Face used for face tags."
|
|
|
2537 :group 'custom-faces)
|
|
|
2538
|
|
|
2539 (defcustom custom-face-default-form 'selected
|
|
|
2540 "Default form of displaying face definition."
|
|
|
2541 :type '(choice (const all)
|
|
|
2542 (const selected)
|
|
|
2543 (const lisp))
|
|
|
2544 :group 'custom-buffer)
|
|
|
2545
|
|
|
2546 (define-widget 'custom-face 'custom
|
|
|
2547 "Customize face."
|
|
|
2548 :sample-face 'custom-face-tag-face
|
|
|
2549 :help-echo "Set or reset this face"
|
|
4021
|
2550 :documentation-property #'(lambda (face)
|
|
4178
|
2551 (face-doc-string face))
|
|
428
|
2552 :value-create 'custom-face-value-create
|
|
|
2553 :action 'custom-face-action
|
|
|
2554 :custom-category 'face
|
|
|
2555 :custom-form nil ; defaults to value of `custom-face-default-form'
|
|
|
2556 :custom-set 'custom-face-set
|
|
480
|
2557 :custom-pre-save 'custom-face-pre-save
|
|
428
|
2558 :custom-save 'custom-face-save
|
|
480
|
2559 :custom-post-save 'custom-face-post-save
|
|
428
|
2560 :custom-reset-current 'custom-redraw
|
|
|
2561 :custom-reset-saved 'custom-face-reset-saved
|
|
480
|
2562 :custom-pre-reset-standard 'custom-face-pre-reset-standard
|
|
428
|
2563 :custom-reset-standard 'custom-face-reset-standard
|
|
480
|
2564 :custom-post-reset-standard 'custom-face-post-reset-standard
|
|
428
|
2565 :custom-menu 'custom-face-menu-create)
|
|
|
2566
|
|
|
2567 (define-widget 'custom-face-all 'editable-list
|
|
|
2568 "An editable list of display specifications and attributes."
|
|
|
2569 :entry-format "%i %d %v"
|
|
|
2570 :insert-button-args '(:help-echo "Insert new display specification here")
|
|
|
2571 :append-button-args '(:help-echo "Append new display specification here")
|
|
|
2572 :delete-button-args '(:help-echo "Delete this display specification")
|
|
|
2573 :args '((group :format "%v" custom-display custom-face-edit)))
|
|
|
2574
|
|
|
2575 (defconst custom-face-all (widget-convert 'custom-face-all)
|
|
|
2576 "Converted version of the `custom-face-all' widget.")
|
|
|
2577
|
|
|
2578 (define-widget 'custom-display-unselected 'item
|
|
|
2579 "A display specification that doesn't match the selected display."
|
|
|
2580 :match 'custom-display-unselected-match)
|
|
|
2581
|
|
|
2582 (defun custom-display-unselected-match (widget value)
|
|
|
2583 "Non-nil if VALUE is an unselected display specification."
|
|
|
2584 (not (face-spec-set-match-display value (selected-frame))))
|
|
|
2585
|
|
|
2586 (define-widget 'custom-face-selected 'group
|
|
|
2587 "Edit the attributes of the selected display in a face specification."
|
|
|
2588 :args '((repeat :format ""
|
|
|
2589 :inline t
|
|
|
2590 (group custom-display-unselected sexp))
|
|
|
2591 (group (sexp :format "") custom-face-edit)
|
|
|
2592 (repeat :format ""
|
|
|
2593 :inline t
|
|
|
2594 sexp)))
|
|
|
2595
|
|
|
2596 (defconst custom-face-selected (widget-convert 'custom-face-selected)
|
|
|
2597 "Converted version of the `custom-face-selected' widget.")
|
|
|
2598
|
|
|
2599 (defun custom-face-value-create (widget)
|
|
|
2600 "Create a list of the display specifications for WIDGET."
|
|
|
2601 (let ((buttons (widget-get widget :buttons))
|
|
|
2602 children
|
|
|
2603 (symbol (widget-get widget :value))
|
|
|
2604 (tag (widget-get widget :tag))
|
|
|
2605 (state (widget-get widget :custom-state))
|
|
|
2606 (begin (point))
|
|
|
2607 (is-last (widget-get widget :custom-last))
|
|
|
2608 (prefix (widget-get widget :custom-prefix)))
|
|
|
2609 (unless tag
|
|
|
2610 (setq tag (prin1-to-string symbol)))
|
|
|
2611 (cond ((eq custom-buffer-style 'tree)
|
|
|
2612 (insert prefix (if is-last " `--- " " |--- "))
|
|
|
2613 (push (widget-create-child-and-convert
|
|
|
2614 widget 'custom-browse-face-tag)
|
|
|
2615 buttons)
|
|
|
2616 (insert " " tag "\n")
|
|
|
2617 (widget-put widget :buttons buttons))
|
|
|
2618 (t
|
|
|
2619 ;; Create tag.
|
|
|
2620 (insert tag)
|
|
|
2621 (if (eq custom-buffer-style 'face)
|
|
|
2622 (insert " ")
|
|
|
2623 (widget-specify-sample widget begin (point))
|
|
|
2624 (insert ": "))
|
|
|
2625 ;; Sample.
|
|
|
2626 (and (not (find-face symbol))
|
|
|
2627 ;; XEmacs cannot display uninitialized faces.
|
|
|
2628 (make-face symbol))
|
|
|
2629 (push (widget-create-child-and-convert widget 'item
|
|
|
2630 :format "(%{%t%})"
|
|
|
2631 :sample-face symbol
|
|
|
2632 :tag "sample")
|
|
|
2633 buttons)
|
|
|
2634 ;; Visibility.
|
|
|
2635 (insert " ")
|
|
|
2636 (push (widget-create-child-and-convert
|
|
|
2637 widget 'visibility
|
|
|
2638 :help-echo "Hide or show this face"
|
|
|
2639 :action 'custom-toggle-parent
|
|
|
2640 (not (eq state 'hidden)))
|
|
|
2641 buttons)
|
|
|
2642 ;; Magic.
|
|
|
2643 (insert "\n")
|
|
|
2644 (let ((magic (widget-create-child-and-convert
|
|
|
2645 widget 'custom-magic nil)))
|
|
|
2646 (widget-put widget :custom-magic magic)
|
|
|
2647 (push magic buttons))
|
|
|
2648 ;; Update buttons.
|
|
|
2649 (widget-put widget :buttons buttons)
|
|
|
2650 ;; Insert documentation.
|
|
|
2651 (widget-default-format-handler widget ?h)
|
|
|
2652 ;; The comment field
|
|
|
2653 (unless (eq state 'hidden)
|
|
|
2654 (let* ((comment (get symbol 'face-comment))
|
|
|
2655 (comment-widget
|
|
|
2656 (widget-create-child-and-convert
|
|
|
2657 widget 'custom-comment
|
|
|
2658 :parent widget
|
|
|
2659 :value (or comment ""))))
|
|
|
2660 (widget-put widget :comment-widget comment-widget)
|
|
|
2661 (push comment-widget children)))
|
|
|
2662 ;; See also.
|
|
|
2663 (unless (eq state 'hidden)
|
|
|
2664 (when (eq (widget-get widget :custom-level) 1)
|
|
|
2665 (custom-add-parent-links widget))
|
|
|
2666 (custom-add-see-also widget))
|
|
|
2667 ;; Editor.
|
|
|
2668 (unless (eq (preceding-char) ?\n)
|
|
|
2669 (insert "\n"))
|
|
|
2670 (unless (eq state 'hidden)
|
|
|
2671 (message "Creating face editor...")
|
|
|
2672 (custom-load-widget widget)
|
|
|
2673 (unless (widget-get widget :custom-form)
|
|
|
2674 (widget-put widget :custom-form custom-face-default-form))
|
|
|
2675 (let* ((symbol (widget-value widget))
|
|
|
2676 (spec (custom-face-get-spec symbol))
|
|
|
2677 (form (widget-get widget :custom-form))
|
|
|
2678 (indent (widget-get widget :indent))
|
|
|
2679 (edit (widget-create-child-and-convert
|
|
|
2680 widget
|
|
|
2681 (cond ((and (eq form 'selected)
|
|
|
2682 (widget-apply custom-face-selected
|
|
|
2683 :match spec))
|
|
|
2684 (when indent (insert-char ?\ indent))
|
|
|
2685 'custom-face-selected)
|
|
|
2686 ((and (not (eq form 'lisp))
|
|
|
2687 (widget-apply custom-face-all
|
|
|
2688 :match spec))
|
|
|
2689 'custom-face-all)
|
|
|
2690 (t
|
|
|
2691 (when indent (insert-char ?\ indent))
|
|
|
2692 'sexp))
|
|
|
2693 :value spec)))
|
|
|
2694 (custom-face-state-set widget)
|
|
|
2695 (push edit children)
|
|
|
2696 (widget-put widget :children children))
|
|
|
2697 (message "Creating face editor...done"))))))
|
|
|
2698
|
|
|
2699 (defvar custom-face-menu
|
|
4289
|
2700 `(("Set for Current Session" custom-face-set)
|
|
428
|
2701 ("Save for Future Sessions" custom-face-save)
|
|
|
2702 ("Reset to Saved" custom-face-reset-saved
|
|
4289
|
2703 ,#'(lambda (widget)
|
|
|
2704 (or (get (widget-value widget) 'saved-face)
|
|
|
2705 (get (widget-value widget) 'saved-face-comment))))
|
|
428
|
2706 ("Reset to Standard Setting" custom-face-reset-standard
|
|
4289
|
2707 ,#'(lambda (widget)
|
|
|
2708 (get (widget-value widget) 'face-defface-spec)))
|
|
428
|
2709 ("---" ignore ignore)
|
|
|
2710 ("Add Comment" custom-comment-show custom-comment-invisible-p)
|
|
|
2711 ("---" ignore ignore)
|
|
|
2712 ("Show all display specs" custom-face-edit-all
|
|
4289
|
2713 ,#'(lambda (widget)
|
|
|
2714 (not (eq (widget-get widget :custom-form) 'all))))
|
|
428
|
2715 ("Just current attributes" custom-face-edit-selected
|
|
4289
|
2716 ,#'(lambda (widget)
|
|
|
2717 (not (eq (widget-get widget :custom-form) 'selected))))
|
|
428
|
2718 ("Show as Lisp expression" custom-face-edit-lisp
|
|
4289
|
2719 ,#'(lambda (widget)
|
|
|
2720 (not (eq (widget-get widget :custom-form) 'lisp)))))
|
|
428
|
2721 "Alist of actions for the `custom-face' widget.
|
|
|
2722 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
|
|
|
2723 the menu entry, ACTION is the function to call on the widget when the
|
|
|
2724 menu is selected, and FILTER is a predicate which takes a `custom-face'
|
|
|
2725 widget as an argument, and returns non-nil if ACTION is valid on that
|
|
|
2726 widget. If FILTER is nil, ACTION is always valid.")
|
|
|
2727
|
|
|
2728 (defun custom-face-edit-selected (widget)
|
|
|
2729 "Edit selected attributes of the value of WIDGET."
|
|
|
2730 (widget-put widget :custom-state 'unknown)
|
|
|
2731 (widget-put widget :custom-form 'selected)
|
|
|
2732 (custom-redraw widget))
|
|
|
2733
|
|
|
2734 (defun custom-face-edit-all (widget)
|
|
|
2735 "Edit all attributes of the value of WIDGET."
|
|
|
2736 (widget-put widget :custom-state 'unknown)
|
|
|
2737 (widget-put widget :custom-form 'all)
|
|
|
2738 (custom-redraw widget))
|
|
|
2739
|
|
|
2740 (defun custom-face-edit-lisp (widget)
|
|
|
2741 "Edit the lisp representation of the value of WIDGET."
|
|
|
2742 (widget-put widget :custom-state 'unknown)
|
|
|
2743 (widget-put widget :custom-form 'lisp)
|
|
|
2744 (custom-redraw widget))
|
|
|
2745
|
|
|
2746 (defun custom-face-state-set (widget)
|
|
|
2747 "Set the state of WIDGET."
|
|
|
2748 (let* ((symbol (widget-value widget))
|
|
|
2749 (comment (get symbol 'face-comment))
|
|
|
2750 tmp temp)
|
|
|
2751 (widget-put widget :custom-state
|
|
|
2752 (cond ((progn
|
|
|
2753 (setq tmp (get symbol 'customized-face))
|
|
|
2754 (setq temp (get symbol 'customized-face-comment))
|
|
|
2755 (or tmp temp))
|
|
|
2756 (if (equal temp comment)
|
|
|
2757 'set
|
|
|
2758 'changed))
|
|
|
2759 ((progn
|
|
|
2760 (setq tmp (get symbol 'saved-face))
|
|
|
2761 (setq temp (get symbol 'saved-face-comment))
|
|
|
2762 (or tmp temp))
|
|
|
2763 (if (equal temp comment)
|
|
|
2764 'saved
|
|
|
2765 'changed))
|
|
|
2766 ((get symbol 'face-defface-spec)
|
|
|
2767 (if (equal comment nil)
|
|
|
2768 'standard
|
|
|
2769 'changed))
|
|
|
2770 (t
|
|
|
2771 'rogue)))))
|
|
|
2772
|
|
|
2773 (defun custom-face-action (widget &optional event)
|
|
|
2774 "Show the menu for `custom-face' WIDGET.
|
|
|
2775 Optional EVENT is the location for the menu."
|
|
|
2776 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
|
2777 (custom-toggle-hide widget)
|
|
|
2778 (let* ((completion-ignore-case t)
|
|
|
2779 (symbol (widget-get widget :value))
|
|
|
2780 (answer (widget-choose (concat "Operation on "
|
|
|
2781 (custom-unlispify-tag-name symbol))
|
|
|
2782 (custom-menu-filter custom-face-menu
|
|
|
2783 widget)
|
|
|
2784 event)))
|
|
|
2785 (if answer
|
|
|
2786 (funcall answer widget)))))
|
|
|
2787
|
|
|
2788 (defun custom-face-set (widget)
|
|
|
2789 "Make the face attributes in WIDGET take effect."
|
|
|
2790 (let* ((symbol (widget-value widget))
|
|
|
2791 (child (car (widget-get widget :children)))
|
|
|
2792 (value (widget-value child))
|
|
|
2793 (comment-widget (widget-get widget :comment-widget))
|
|
|
2794 (comment (widget-value comment-widget)))
|
|
|
2795 (when (equal comment "")
|
|
|
2796 (setq comment nil)
|
|
|
2797 ;; Make the comment invisible by hand if it's empty
|
|
|
2798 (set-extent-property (widget-get comment-widget :comment-extent)
|
|
|
2799 'invisible t))
|
|
|
2800 (put symbol 'customized-face value)
|
|
|
2801 (face-spec-set symbol value nil '(custom))
|
|
|
2802 (put symbol 'customized-face-comment comment)
|
|
|
2803 (put symbol 'face-comment comment)
|
|
|
2804 (custom-face-state-set widget)
|
|
|
2805 (custom-redraw-magic widget)))
|
|
|
2806
|
|
480
|
2807 (defun custom-face-pre-save (widget)
|
|
|
2808 "Prepare for saving the face being edited by WIDGET."
|
|
428
|
2809 (let* ((symbol (widget-value widget))
|
|
|
2810 (child (car (widget-get widget :children)))
|
|
|
2811 (value (widget-value child))
|
|
|
2812 (comment-widget (widget-get widget :comment-widget))
|
|
|
2813 (comment (widget-value comment-widget)))
|
|
|
2814 (when (equal comment "")
|
|
|
2815 (setq comment nil)
|
|
|
2816 ;; Make the comment invisible by hand if it's empty
|
|
|
2817 (set-extent-property (widget-get comment-widget :comment-extent)
|
|
|
2818 'invisible t))
|
|
|
2819 (face-spec-set symbol value nil '(custom))
|
|
|
2820 (put symbol 'saved-face value)
|
|
|
2821 (custom-push-theme 'theme-face symbol 'user 'set value)
|
|
|
2822 (put symbol 'customized-face nil)
|
|
|
2823 (put symbol 'face-comment comment)
|
|
|
2824 (put symbol 'customized-face-comment nil)
|
|
|
2825 (put symbol 'saved-face-comment comment)
|
|
480
|
2826 ))
|
|
|
2827
|
|
|
2828 (defun custom-face-post-save (widget)
|
|
|
2829 "Finish saving the face being edited by WIDGET."
|
|
|
2830 (custom-face-state-set widget)
|
|
|
2831 (custom-redraw-magic widget))
|
|
|
2832
|
|
|
2833 (defun custom-face-save (widget)
|
|
|
2834 "Save the face being edited by WIDGET."
|
|
|
2835 (custom-face-pre-save widget)
|
|
|
2836 (custom-save-all)
|
|
|
2837 (custom-face-post-save widget))
|
|
428
|
2838
|
|
|
2839 (defun custom-face-reset-saved (widget)
|
|
480
|
2840 "Reset the face being edited by WIDGET to its saved value."
|
|
428
|
2841 (let* ((symbol (widget-value widget))
|
|
|
2842 (child (car (widget-get widget :children)))
|
|
|
2843 (value (get symbol 'saved-face))
|
|
|
2844 (comment (get symbol 'saved-face-comment))
|
|
|
2845 (comment-widget (widget-get widget :comment-widget)))
|
|
|
2846 (unless (or value comment)
|
|
|
2847 (signal 'error (list "No saved value for this face" symbol)))
|
|
|
2848 (put symbol 'customized-face nil)
|
|
|
2849 (put symbol 'customized-face-comment nil)
|
|
|
2850 (face-spec-set symbol value nil '(custom))
|
|
|
2851 (put symbol 'face-comment comment)
|
|
|
2852 (widget-value-set child value)
|
|
|
2853 ;; This call manages the comment visibility
|
|
|
2854 (widget-value-set comment-widget (or comment ""))
|
|
|
2855 (custom-face-state-set widget)
|
|
|
2856 (custom-redraw-magic widget)))
|
|
|
2857
|
|
480
|
2858 ;; This function returns non nil if we need to re-save the options --dv.
|
|
|
2859 (defun custom-face-pre-reset-standard (widget)
|
|
|
2860 "Prepare for restoring the face edited by WIDGET to its standard
|
|
|
2861 settings."
|
|
428
|
2862 (let* ((symbol (widget-value widget))
|
|
480
|
2863 (value (get symbol 'face-defface-spec)))
|
|
428
|
2864 (unless value
|
|
|
2865 (signal 'error (list "No standard setting for this face" symbol)))
|
|
|
2866 (put symbol 'customized-face nil)
|
|
|
2867 (put symbol 'customized-face-comment nil)
|
|
|
2868 (when (or (get symbol 'saved-face) (get symbol 'saved-face-comment))
|
|
|
2869 (put symbol 'saved-face nil)
|
|
|
2870 (custom-push-theme 'theme-face symbol 'user 'reset 'standard)
|
|
|
2871 ;; Do not explictly save resets to standards without themes.
|
|
|
2872 (if (null (cdr (get symbol 'theme-face)))
|
|
|
2873 (put symbol 'theme-face nil))
|
|
|
2874 (put symbol 'saved-face-comment nil)
|
|
480
|
2875 widget)
|
|
|
2876 ))
|
|
|
2877
|
|
|
2878 (defun custom-face-post-reset-standard (widget)
|
|
|
2879 "Finish restoring the face edited by WIDGET to its standard settings."
|
|
|
2880 (let* ((symbol (widget-value widget))
|
|
|
2881 (child (car (widget-get widget :children)))
|
|
|
2882 (value (get symbol 'face-defface-spec))
|
|
|
2883 (comment-widget (widget-get widget :comment-widget)))
|
|
428
|
2884 (face-spec-set symbol value nil '(custom))
|
|
|
2885 (put symbol 'face-comment nil)
|
|
|
2886 (widget-value-set child value)
|
|
|
2887 ;; This call manages the comment visibility
|
|
|
2888 (widget-value-set comment-widget "")
|
|
|
2889 (custom-face-state-set widget)
|
|
480
|
2890 (custom-redraw-magic widget)
|
|
|
2891 ))
|
|
|
2892
|
|
|
2893 (defun custom-face-reset-standard (widget)
|
|
|
2894 "Restore the face edited by WIDGET to its standard settings."
|
|
|
2895 (when (custom-face-pre-reset-standard widget)
|
|
|
2896 (custom-save-all))
|
|
|
2897 (custom-face-post-reset-standard widget))
|
|
|
2898
|
|
428
|
2899
|
|
|
2900 ;;; The `face' Widget.
|
|
|
2901
|
|
|
2902 (define-widget 'face 'default
|
|
|
2903 "Select and customize a face."
|
|
|
2904 :convert-widget 'widget-value-convert-widget
|
|
|
2905 :button-prefix 'widget-push-button-prefix
|
|
|
2906 :button-suffix 'widget-push-button-suffix
|
|
|
2907 :format "%t: %[select face%] %v"
|
|
|
2908 :tag "Face"
|
|
|
2909 :value 'default
|
|
|
2910 :value-create 'widget-face-value-create
|
|
|
2911 :value-delete 'widget-face-value-delete
|
|
|
2912 :value-get 'widget-value-value-get
|
|
|
2913 :validate 'widget-children-validate
|
|
|
2914 :action 'widget-face-action
|
|
|
2915 :match (lambda (widget value) (symbolp value)))
|
|
|
2916
|
|
|
2917 (defun widget-face-value-create (widget)
|
|
|
2918 ;; Create a `custom-face' child.
|
|
|
2919 (let* ((symbol (widget-value widget))
|
|
|
2920 (custom-buffer-style 'face)
|
|
|
2921 (child (widget-create-child-and-convert
|
|
|
2922 widget 'custom-face
|
|
|
2923 :custom-level nil
|
|
|
2924 :value symbol)))
|
|
|
2925 (custom-magic-reset child)
|
|
|
2926 (setq custom-options (cons child custom-options))
|
|
|
2927 (widget-put widget :children (list child))))
|
|
|
2928
|
|
|
2929 (defun widget-face-value-delete (widget)
|
|
|
2930 ;; Remove the child from the options.
|
|
|
2931 (let ((child (car (widget-get widget :children))))
|
|
|
2932 (setq custom-options (delq child custom-options))
|
|
|
2933 (widget-children-value-delete widget)))
|
|
|
2934
|
|
|
2935 (defvar face-history nil
|
|
|
2936 "History of entered face names.")
|
|
|
2937
|
|
|
2938 (defun widget-face-action (widget &optional event)
|
|
|
2939 "Prompt for a face."
|
|
|
2940 (let ((answer (completing-read "Face: "
|
|
|
2941 (mapcar (lambda (face)
|
|
|
2942 (list (symbol-name face)))
|
|
|
2943 (face-list))
|
|
|
2944 nil nil nil
|
|
|
2945 'face-history)))
|
|
|
2946 (unless (zerop (length answer))
|
|
|
2947 (widget-value-set widget (intern answer))
|
|
|
2948 (widget-apply widget :notify widget event)
|
|
|
2949 (widget-setup))))
|
|
|
2950
|
|
|
2951 ;;; The `hook' Widget.
|
|
|
2952
|
|
|
2953 (define-widget 'hook 'list
|
|
|
2954 "A emacs lisp hook"
|
|
|
2955 :value-to-internal (lambda (widget value)
|
|
|
2956 (if (symbolp value)
|
|
|
2957 (list value)
|
|
|
2958 value))
|
|
|
2959 :match (lambda (widget value)
|
|
|
2960 (or (symbolp value)
|
|
|
2961 (widget-group-match widget value)))
|
|
|
2962 :convert-widget 'custom-hook-convert-widget
|
|
|
2963 :tag "Hook")
|
|
|
2964
|
|
|
2965 (defun custom-hook-convert-widget (widget)
|
|
438
|
2966 ;; Handle `:options'.
|
|
428
|
2967 (let* ((options (widget-get widget :options))
|
|
|
2968 (other `(editable-list :inline t
|
|
|
2969 :entry-format "%i %d%v"
|
|
|
2970 (function :format " %v")))
|
|
|
2971 (args (if options
|
|
|
2972 (list `(checklist :inline t
|
|
|
2973 ,@(mapcar (lambda (entry)
|
|
|
2974 `(function-item ,entry))
|
|
|
2975 options))
|
|
|
2976 other)
|
|
|
2977 (list other))))
|
|
|
2978 (widget-put widget :args args)
|
|
|
2979 widget))
|
|
|
2980
|
|
|
2981 ;;; The `plist' Widget.
|
|
|
2982
|
|
|
2983 (define-widget 'plist 'list
|
|
|
2984 "A property list."
|
|
|
2985 :match (lambda (widget value)
|
|
|
2986 (valid-plist-p value))
|
|
|
2987 :convert-widget 'custom-plist-convert-widget
|
|
|
2988 :tag "Property List")
|
|
|
2989
|
|
|
2990 ;; #### Should handle options better.
|
|
|
2991 (defun custom-plist-convert-widget (widget)
|
|
|
2992 (let* ((options (widget-get widget :options))
|
|
|
2993 (other `(editable-list :inline t
|
|
|
2994 (group :inline t
|
|
|
2995 (symbol :format "%t: %v "
|
|
|
2996 :size 10
|
|
|
2997 :tag "Property")
|
|
|
2998 (sexp :tag "Value"))))
|
|
|
2999 (args
|
|
|
3000 (if options
|
|
|
3001 `((checklist :inline t
|
|
|
3002 ,@(mapcar 'custom-plist-process-option options))
|
|
|
3003 ,other)
|
|
|
3004 (list other))))
|
|
|
3005 (widget-put widget :args args)
|
|
|
3006 widget))
|
|
|
3007
|
|
|
3008 (defun custom-plist-process-option (entry)
|
|
|
3009 `(group :inline t
|
|
|
3010 (const :tag "Property"
|
|
|
3011 :format "%t: %v "
|
|
|
3012 :size 10
|
|
|
3013 ,entry)
|
|
|
3014 (sexp :tag "Value")))
|
|
|
3015
|
|
|
3016 ;;; The `custom-group-link' Widget.
|
|
|
3017
|
|
|
3018 (define-widget 'custom-group-link 'link
|
|
|
3019 "Show parent in other window when activated."
|
|
|
3020 :help-echo 'custom-group-link-help-echo
|
|
|
3021 :action 'custom-group-link-action)
|
|
|
3022
|
|
|
3023 (defun custom-group-link-help-echo (widget)
|
|
|
3024 (concat "Create customization buffer for the `"
|
|
|
3025 (custom-unlispify-tag-name (widget-value widget))
|
|
|
3026 "' group"))
|
|
|
3027
|
|
|
3028 (defun custom-group-link-action (widget &rest ignore)
|
|
|
3029 (customize-group (widget-value widget)))
|
|
|
3030
|
|
|
3031 ;;; The `custom-group' Widget.
|
|
|
3032
|
|
|
3033 (defcustom custom-group-tag-faces nil
|
|
|
3034 ;; In XEmacs, this ought to play games with font size.
|
|
|
3035 "Face used for group tags.
|
|
|
3036 The first member is used for level 1 groups, the second for level 2,
|
|
|
3037 and so forth. The remaining group tags are shown with
|
|
|
3038 `custom-group-tag-face'."
|
|
|
3039 :type '(repeat face)
|
|
|
3040 :group 'custom-faces)
|
|
|
3041
|
|
|
3042 (defface custom-group-tag-face-1 '((((class color)
|
|
|
3043 (background dark))
|
|
|
3044 (:foreground "pink" :underline t))
|
|
|
3045 (((class color)
|
|
|
3046 (background light))
|
|
|
3047 (:foreground "red" :underline t))
|
|
|
3048 (t (:underline t)))
|
|
|
3049 "Face used for group tags.")
|
|
|
3050
|
|
|
3051 (defface custom-group-tag-face '((((class color)
|
|
|
3052 (background dark))
|
|
|
3053 (:foreground "light blue" :underline t))
|
|
|
3054 (((class color)
|
|
|
3055 (background light))
|
|
|
3056 (:foreground "blue" :underline t))
|
|
|
3057 (t (:underline t)))
|
|
|
3058 "Face used for low level group tags."
|
|
|
3059 :group 'custom-faces)
|
|
|
3060
|
|
|
3061 (define-widget 'custom-group 'custom
|
|
|
3062 "Customize group."
|
|
|
3063 :format "%v"
|
|
|
3064 :sample-face-get 'custom-group-sample-face-get
|
|
|
3065 :documentation-property 'group-documentation
|
|
|
3066 :help-echo "Set or reset all members of this group"
|
|
|
3067 :value-create 'custom-group-value-create
|
|
|
3068 :action 'custom-group-action
|
|
|
3069 :custom-category 'group
|
|
|
3070 :custom-set 'custom-group-set
|
|
480
|
3071 :custom-pre-save 'custom-group-pre-save
|
|
428
|
3072 :custom-save 'custom-group-save
|
|
480
|
3073 :custom-post-save 'custom-group-post-save
|
|
428
|
3074 :custom-reset-current 'custom-group-reset-current
|
|
|
3075 :custom-reset-saved 'custom-group-reset-saved
|
|
480
|
3076 :custom-pre-reset-standard 'custom-group-pre-reset-standard
|
|
428
|
3077 :custom-reset-standard 'custom-group-reset-standard
|
|
480
|
3078 :custom-post-reset-standard 'custom-group-post-reset-standard
|
|
428
|
3079 :custom-menu 'custom-group-menu-create)
|
|
|
3080
|
|
|
3081 (defun custom-group-sample-face-get (widget)
|
|
|
3082 ;; Use :sample-face.
|
|
|
3083 (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces)
|
|
|
3084 'custom-group-tag-face))
|
|
|
3085
|
|
|
3086 (define-widget 'custom-group-visibility 'visibility
|
|
|
3087 "An indicator and manipulator for hidden group contents."
|
|
|
3088 :create 'custom-group-visibility-create)
|
|
|
3089
|
|
|
3090 (defun custom-group-visibility-create (widget)
|
|
|
3091 (let ((visible (widget-value widget)))
|
|
|
3092 (if visible
|
|
|
3093 (insert "--------")))
|
|
|
3094 (widget-default-create widget))
|
|
|
3095
|
|
|
3096 (defun custom-group-members (symbol groups-only)
|
|
|
3097 "Return SYMBOL's custom group members.
|
|
|
3098 If GROUPS-ONLY non-nil, return only those members that are groups."
|
|
|
3099 (if (not groups-only)
|
|
|
3100 (get symbol 'custom-group)
|
|
|
3101 (let (members)
|
|
|
3102 (dolist (entry (get symbol 'custom-group) (nreverse members))
|
|
|
3103 (when (eq (nth 1 entry) 'custom-group)
|
|
|
3104 (push entry members))))))
|
|
|
3105
|
|
|
3106 (defun custom-group-value-create (widget)
|
|
|
3107 "Insert a customize group for WIDGET in the current buffer."
|
|
|
3108 (let* ((state (widget-get widget :custom-state))
|
|
|
3109 (level (widget-get widget :custom-level))
|
|
|
3110 ;; (indent (widget-get widget :indent))
|
|
|
3111 (prefix (widget-get widget :custom-prefix))
|
|
|
3112 (buttons (widget-get widget :buttons))
|
|
|
3113 (tag (widget-get widget :tag))
|
|
|
3114 (symbol (widget-value widget))
|
|
|
3115 (members (custom-group-members symbol
|
|
|
3116 (and (eq custom-buffer-style 'tree)
|
|
|
3117 custom-browse-only-groups))))
|
|
|
3118 (cond ((and (eq custom-buffer-style 'tree)
|
|
|
3119 (eq state 'hidden)
|
|
|
3120 (or members (custom-unloaded-widget-p widget)))
|
|
|
3121 (custom-browse-insert-prefix prefix)
|
|
|
3122 (push (widget-create-child-and-convert
|
|
|
3123 widget 'custom-browse-visibility
|
|
|
3124 ;; :tag-glyph "plus"
|
|
|
3125 :tag "+")
|
|
|
3126 buttons)
|
|
|
3127 (insert "-- ")
|
|
|
3128 ;; (widget-glyph-insert nil "-- " "horizontal")
|
|
|
3129 (push (widget-create-child-and-convert
|
|
|
3130 widget 'custom-browse-group-tag)
|
|
|
3131 buttons)
|
|
|
3132 (insert " " tag "\n")
|
|
|
3133 (widget-put widget :buttons buttons))
|
|
|
3134 ((and (eq custom-buffer-style 'tree)
|
|
|
3135 (zerop (length members)))
|
|
|
3136 (custom-browse-insert-prefix prefix)
|
|
|
3137 (insert "[ ]-- ")
|
|
|
3138 ;; (widget-glyph-insert nil "[ ]" "empty")
|
|
|
3139 ;; (widget-glyph-insert nil "-- " "horizontal")
|
|
|
3140 (push (widget-create-child-and-convert
|
|
|
3141 widget 'custom-browse-group-tag)
|
|
|
3142 buttons)
|
|
|
3143 (insert " " tag "\n")
|
|
|
3144 (widget-put widget :buttons buttons))
|
|
|
3145 ((eq custom-buffer-style 'tree)
|
|
|
3146 (custom-browse-insert-prefix prefix)
|
|
|
3147 (custom-load-widget widget)
|
|
|
3148 (if (zerop (length members))
|
|
|
3149 (progn
|
|
|
3150 (custom-browse-insert-prefix prefix)
|
|
|
3151 (insert "[ ]-- ")
|
|
|
3152 ;; (widget-glyph-insert nil "[ ]" "empty")
|
|
|
3153 ;; (widget-glyph-insert nil "-- " "horizontal")
|
|
|
3154 (push (widget-create-child-and-convert
|
|
|
3155 widget 'custom-browse-group-tag)
|
|
|
3156 buttons)
|
|
|
3157 (insert " " tag "\n")
|
|
|
3158 (widget-put widget :buttons buttons))
|
|
|
3159 (push (widget-create-child-and-convert
|
|
|
3160 widget 'custom-browse-visibility
|
|
|
3161 ;; :tag-glyph "minus"
|
|
|
3162 :tag "-")
|
|
|
3163 buttons)
|
|
|
3164 (insert "-\\ ")
|
|
|
3165 ;; (widget-glyph-insert nil "-\\ " "top")
|
|
|
3166 (push (widget-create-child-and-convert
|
|
|
3167 widget 'custom-browse-group-tag)
|
|
|
3168 buttons)
|
|
|
3169 (insert " " tag "\n")
|
|
|
3170 (widget-put widget :buttons buttons)
|
|
|
3171 (message "Creating group...")
|
|
|
3172 (let* ((members (custom-sort-items members
|
|
|
3173 custom-browse-sort-alphabetically
|
|
|
3174 custom-browse-order-groups))
|
|
|
3175 (prefixes (widget-get widget :custom-prefixes))
|
|
|
3176 (custom-prefix-list (custom-prefix-add symbol prefixes))
|
|
|
3177 (extra-prefix (if (widget-get widget :custom-last)
|
|
|
3178 " "
|
|
|
3179 " | "))
|
|
|
3180 (prefix (concat prefix extra-prefix))
|
|
|
3181 children entry)
|
|
|
3182 (while members
|
|
|
3183 (setq entry (car members)
|
|
|
3184 members (cdr members))
|
|
|
3185 (push (widget-create-child-and-convert
|
|
|
3186 widget (nth 1 entry)
|
|
|
3187 :group widget
|
|
|
3188 :tag (custom-unlispify-tag-name (nth 0 entry))
|
|
|
3189 :custom-prefixes custom-prefix-list
|
|
|
3190 :custom-level (1+ level)
|
|
|
3191 :custom-last (null members)
|
|
|
3192 :value (nth 0 entry)
|
|
|
3193 :custom-prefix prefix)
|
|
|
3194 children))
|
|
|
3195 (widget-put widget :children (reverse children)))
|
|
|
3196 (message "Creating group...done")))
|
|
|
3197 ;; Nested style.
|
|
|
3198 ((eq state 'hidden)
|
|
|
3199 ;; Create level indicator.
|
|
|
3200 (unless (eq custom-buffer-style 'links)
|
|
|
3201 (insert-char ?\ (* custom-buffer-indent (1- level)))
|
|
|
3202 (insert "-- "))
|
|
|
3203 ;; Create link indicator.
|
|
|
3204 (when (eq custom-buffer-style 'links)
|
|
|
3205 (insert " ")
|
|
|
3206 (push (widget-create-child-and-convert
|
|
|
3207 widget 'custom-group-link
|
|
|
3208 :tag "Open"
|
|
|
3209 :tag-glyph '("open-up" "open-down")
|
|
|
3210 symbol)
|
|
|
3211 buttons)
|
|
|
3212 (insert " "))
|
|
|
3213 ;; Create tag.
|
|
|
3214 (let ((begin (point)))
|
|
|
3215 (insert tag)
|
|
|
3216 (widget-specify-sample widget begin (point)))
|
|
|
3217 (insert " group")
|
|
|
3218 ;; Create visibility indicator.
|
|
|
3219 (unless (eq custom-buffer-style 'links)
|
|
|
3220 (insert ": ")
|
|
|
3221 (push (widget-create-child-and-convert
|
|
|
3222 widget 'custom-group-visibility
|
|
|
3223 :help-echo "Show members of this group"
|
|
|
3224 :action 'custom-toggle-parent
|
|
|
3225 (not (eq state 'hidden)))
|
|
|
3226 buttons))
|
|
|
3227 (insert " \n")
|
|
|
3228 ;; Create magic button.
|
|
|
3229 (let ((magic (widget-create-child-and-convert
|
|
|
3230 widget 'custom-magic nil)))
|
|
|
3231 (widget-put widget :custom-magic magic)
|
|
|
3232 (push magic buttons))
|
|
|
3233 ;; Update buttons.
|
|
|
3234 (widget-put widget :buttons buttons)
|
|
|
3235 ;; Insert documentation.
|
|
|
3236 (if (and (eq custom-buffer-style 'links) (> level 1))
|
|
|
3237 (widget-put widget :documentation-indent 0))
|
|
|
3238 (widget-default-format-handler widget ?h))
|
|
|
3239 ;; Nested style.
|
|
|
3240 (t ;Visible.
|
|
|
3241 (custom-load-widget widget)
|
|
|
3242 ;; Update members
|
|
|
3243 (setq members (custom-group-members
|
|
|
3244 symbol (and (eq custom-buffer-style 'tree)
|
|
|
3245 custom-browse-only-groups)))
|
|
|
3246 ;; Add parent groups references above the group.
|
|
|
3247 (if t ;;; This should test that the buffer
|
|
|
3248 ;;; was made to display a group.
|
|
|
3249 (when (eq level 1)
|
|
|
3250 (if (custom-add-parent-links widget
|
|
|
3251 "Go to parent group:")
|
|
|
3252 (insert "\n"))))
|
|
|
3253 ;; Create level indicator.
|
|
|
3254 (insert-char ?\ (* custom-buffer-indent (1- level)))
|
|
|
3255 (insert "/- ")
|
|
|
3256 ;; Create tag.
|
|
|
3257 (let ((start (point)))
|
|
|
3258 (insert tag)
|
|
|
3259 (widget-specify-sample widget start (point)))
|
|
|
3260 (insert " group: ")
|
|
|
3261 ;; Create visibility indicator.
|
|
|
3262 (unless (eq custom-buffer-style 'links)
|
|
|
3263 (insert "--------")
|
|
|
3264 (push (widget-create-child-and-convert
|
|
|
3265 widget 'visibility
|
|
|
3266 :help-echo "Hide members of this group"
|
|
|
3267 :action 'custom-toggle-parent
|
|
|
3268 (not (eq state 'hidden)))
|
|
|
3269 buttons)
|
|
|
3270 (insert " "))
|
|
|
3271 ;; Create more dashes.
|
|
|
3272 ;; Use 76 instead of 75 to compensate for the temporary "<"
|
|
|
3273 ;; added by `widget-insert'.
|
|
|
3274 (insert-char ?- (- 76 (current-column)
|
|
|
3275 (* custom-buffer-indent level)))
|
|
|
3276 (insert "\\\n")
|
|
|
3277 ;; Create magic button.
|
|
|
3278 (let ((magic (widget-create-child-and-convert
|
|
|
3279 widget 'custom-magic
|
|
|
3280 :indent 0
|
|
|
3281 nil)))
|
|
|
3282 (widget-put widget :custom-magic magic)
|
|
|
3283 (push magic buttons))
|
|
|
3284 ;; Update buttons.
|
|
|
3285 (widget-put widget :buttons buttons)
|
|
|
3286 ;; Insert documentation.
|
|
|
3287 (widget-default-format-handler widget ?h)
|
|
|
3288 ;; Parent groups.
|
|
|
3289 (if nil ;;; This should test that the buffer
|
|
|
3290 ;;; was not made to display a group.
|
|
|
3291 (when (eq level 1)
|
|
|
3292 (insert-char ?\ custom-buffer-indent)
|
|
|
3293 (custom-add-parent-links widget)))
|
|
|
3294 (custom-add-see-also widget
|
|
|
3295 (make-string (* custom-buffer-indent level)
|
|
|
3296 ?\ ))
|
|
|
3297 ;; Members.
|
|
|
3298 (message "Creating group...")
|
|
|
3299 (let* ((members (custom-sort-items members
|
|
|
3300 custom-buffer-sort-alphabetically
|
|
|
3301 custom-buffer-order-groups))
|
|
|
3302 (prefixes (widget-get widget :custom-prefixes))
|
|
|
3303 (custom-prefix-list (custom-prefix-add symbol prefixes))
|
|
|
3304 (length (length members))
|
|
|
3305 (count 0)
|
|
|
3306 (children (mapcar
|
|
|
3307 (lambda (entry)
|
|
|
3308 (widget-insert "\n")
|
|
|
3309 (when (zerop (% count custom-skip-messages))
|
|
|
3310 (display-message
|
|
|
3311 'progress
|
|
|
3312 (format "\
|
|
|
3313 Creating group members... %2d%%"
|
|
|
3314 (/ (* 100.0 count) length))))
|
|
|
3315 (incf count)
|
|
|
3316 (prog1
|
|
|
3317 (widget-create-child-and-convert
|
|
|
3318 widget (nth 1 entry)
|
|
|
3319 :group widget
|
|
|
3320 :tag (custom-unlispify-tag-name
|
|
|
3321 (nth 0 entry))
|
|
|
3322 :custom-prefixes custom-prefix-list
|
|
|
3323 :custom-level (1+ level)
|
|
|
3324 :value (nth 0 entry))
|
|
|
3325 (unless (eq (preceding-char) ?\n)
|
|
|
3326 (widget-insert "\n"))))
|
|
|
3327 members)))
|
|
|
3328 (message "Creating group magic...")
|
|
|
3329 (mapc 'custom-magic-reset children)
|
|
|
3330 (message "Creating group state...")
|
|
|
3331 (widget-put widget :children children)
|
|
|
3332 (custom-group-state-update widget)
|
|
|
3333 (message "Creating group... done"))
|
|
|
3334 ;; End line
|
|
|
3335 (insert "\n")
|
|
|
3336 (insert-char ?\ (* custom-buffer-indent (1- level)))
|
|
|
3337 (insert "\\- " (widget-get widget :tag) " group end ")
|
|
|
3338 (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level)))
|
|
|
3339 (insert "/\n")))))
|
|
|
3340
|
|
|
3341 (defvar custom-group-menu
|
|
4289
|
3342 `(("Set for Current Session" custom-group-set
|
|
|
3343 ,#'(lambda (widget)
|
|
|
3344 (eq (widget-get widget :custom-state) 'modified)))
|
|
428
|
3345 ("Save for Future Sessions" custom-group-save
|
|
4289
|
3346 ,#'(lambda (widget)
|
|
|
3347 (memq (widget-get widget :custom-state) '(modified set))))
|
|
428
|
3348 ("Reset to Current" custom-group-reset-current
|
|
4289
|
3349 ,#'(lambda (widget)
|
|
|
3350 (memq (widget-get widget :custom-state) '(modified))))
|
|
428
|
3351 ("Reset to Saved" custom-group-reset-saved
|
|
4289
|
3352 ,#'(lambda (widget)
|
|
|
3353 (memq (widget-get widget :custom-state) '(modified set))))
|
|
428
|
3354 ("Reset to standard setting" custom-group-reset-standard
|
|
4289
|
3355 ,#'(lambda (widget)
|
|
|
3356 (memq (widget-get widget :custom-state) '(modified set saved)))))
|
|
428
|
3357 "Alist of actions for the `custom-group' widget.
|
|
|
3358 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
|
|
|
3359 the menu entry, ACTION is the function to call on the widget when the
|
|
|
3360 menu is selected, and FILTER is a predicate which takes a `custom-group'
|
|
|
3361 widget as an argument, and returns non-nil if ACTION is valid on that
|
|
|
3362 widget. If FILTER is nil, ACTION is always valid.")
|
|
|
3363
|
|
|
3364 (defun custom-group-action (widget &optional event)
|
|
|
3365 "Show the menu for `custom-group' WIDGET.
|
|
|
3366 Optional EVENT is the location for the menu."
|
|
|
3367 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
|
3368 (custom-toggle-hide widget)
|
|
|
3369 (let* ((completion-ignore-case t)
|
|
|
3370 (answer (widget-choose (concat "Operation on "
|
|
|
3371 (custom-unlispify-tag-name
|
|
|
3372 (widget-get widget :value)))
|
|
|
3373 (custom-menu-filter custom-group-menu
|
|
|
3374 widget)
|
|
|
3375 event)))
|
|
|
3376 (if answer
|
|
|
3377 (funcall answer widget)))))
|
|
|
3378
|
|
|
3379 (defun custom-group-set (widget)
|
|
|
3380 "Set changes in all modified group members."
|
|
|
3381 (let ((children (widget-get widget :children)))
|
|
|
3382 (mapc (lambda (child)
|
|
|
3383 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
3384 (widget-apply child :custom-set)))
|
|
|
3385 children)))
|
|
|
3386
|
|
480
|
3387 (defun custom-group-pre-save (widget)
|
|
|
3388 "Prepare for saving all modified group members."
|
|
|
3389 (let ((children (widget-get widget :children)))
|
|
|
3390 (mapc (lambda (child)
|
|
|
3391 (when (memq (widget-get child :custom-state) '(modified set))
|
|
|
3392 (widget-apply child :custom-pre-save)))
|
|
|
3393 children)))
|
|
|
3394
|
|
|
3395 (defun custom-group-post-save (widget)
|
|
428
|
3396 "Save all modified group members."
|
|
|
3397 (let ((children (widget-get widget :children)))
|
|
|
3398 (mapc (lambda (child)
|
|
|
3399 (when (memq (widget-get child :custom-state) '(modified set))
|
|
480
|
3400 (widget-apply child :custom-post-save)))
|
|
428
|
3401 children)))
|
|
|
3402
|
|
480
|
3403 (defun custom-group-save (widget)
|
|
|
3404 "Save all modified group members."
|
|
|
3405 (custom-group-pre-save widget)
|
|
|
3406 (custom-save-all)
|
|
|
3407 (custom-group-post-save widget))
|
|
|
3408
|
|
428
|
3409 (defun custom-group-reset-current (widget)
|
|
|
3410 "Reset all modified group members."
|
|
|
3411 (let ((children (widget-get widget :children)))
|
|
|
3412 (mapc (lambda (child)
|
|
|
3413 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
3414 (widget-apply child :custom-reset-current)))
|
|
|
3415 children)))
|
|
|
3416
|
|
|
3417 (defun custom-group-reset-saved (widget)
|
|
|
3418 "Reset all modified or set group members."
|
|
|
3419 (let ((children (widget-get widget :children)))
|
|
|
3420 (mapc (lambda (child)
|
|
|
3421 (when (memq (widget-get child :custom-state) '(modified set))
|
|
|
3422 (widget-apply child :custom-reset-saved)))
|
|
|
3423 children)))
|
|
|
3424
|
|
480
|
3425 ;; This function returns non nil when we need to re-save the options --dv.
|
|
|
3426 (defun custom-group-pre-reset-standard (widget)
|
|
|
3427 "Prepare for resetting all modified, set, or saved group members."
|
|
|
3428 (let ((children (widget-get widget :children))
|
|
|
3429 must-save)
|
|
|
3430 (mapc (lambda (child)
|
|
|
3431 (when (memq (widget-get child :custom-state)
|
|
|
3432 '(modified set saved))
|
|
|
3433 (and (widget-apply child :custom-pre-reset-standard)
|
|
|
3434 (setq must-save t))))
|
|
|
3435 children)
|
|
|
3436 must-save
|
|
|
3437 ))
|
|
|
3438
|
|
|
3439 (defun custom-group-post-reset-standard (widget)
|
|
|
3440 "Finish resetting all modified, set, or saved group members."
|
|
428
|
3441 (let ((children (widget-get widget :children)))
|
|
|
3442 (mapc (lambda (child)
|
|
|
3443 (when (memq (widget-get child :custom-state)
|
|
|
3444 '(modified set saved))
|
|
480
|
3445 (widget-apply child :custom-post-reset-standard)))
|
|
428
|
3446 children)))
|
|
|
3447
|
|
480
|
3448 (defun custom-group-reset-standard (widget)
|
|
|
3449 "Reset all modified, set, or saved group members."
|
|
|
3450 (when (custom-group-pre-reset-standard widget)
|
|
|
3451 (custom-save-all))
|
|
|
3452 (custom-group-post-reset-standard widget))
|
|
|
3453
|
|
428
|
3454 (defun custom-group-state-update (widget)
|
|
|
3455 "Update magic."
|
|
|
3456 (unless (eq (widget-get widget :custom-state) 'hidden)
|
|
|
3457 (let* ((children (widget-get widget :children))
|
|
|
3458 (states (mapcar (lambda (child)
|
|
|
3459 (widget-get child :custom-state))
|
|
|
3460 children))
|
|
|
3461 (magics custom-magic-alist)
|
|
|
3462 (found 'standard))
|
|
|
3463 (while magics
|
|
|
3464 (let ((magic (car (car magics))))
|
|
|
3465 (if (and (not (eq magic 'hidden))
|
|
|
3466 (memq magic states))
|
|
|
3467 (setq found magic
|
|
|
3468 magics nil)
|
|
|
3469 (setq magics (cdr magics)))))
|
|
|
3470 (widget-put widget :custom-state found)))
|
|
|
3471 (custom-magic-reset widget))
|
|
|
3472
|
|
|
3473 (defun custom-save-delete (symbol)
|
|
|
3474 "Delete the call to SYMBOL form in `custom-file'.
|
|
|
3475 Leave point at the location of the call, or after the last expression."
|
|
|
3476 (let ((find-file-hooks nil)
|
|
|
3477 (auto-mode-alist nil))
|
|
|
3478 (set-buffer (find-file-noselect custom-file)))
|
|
|
3479 (goto-char (point-min))
|
|
|
3480 (catch 'found
|
|
|
3481 (while t
|
|
|
3482 (let ((sexp (condition-case nil
|
|
|
3483 (read (current-buffer))
|
|
|
3484 (end-of-file (throw 'found nil)))))
|
|
|
3485 (when (and (listp sexp)
|
|
|
3486 (eq (car sexp) symbol))
|
|
|
3487 (delete-region (save-excursion
|
|
|
3488 (backward-sexp)
|
|
|
3489 (point))
|
|
|
3490 (point))
|
|
|
3491 (throw 'found nil))))))
|
|
|
3492
|
|
848
|
3493 (defun custom-save-delete-any (&rest symbols)
|
|
|
3494 "Delete the call to any symbol among SYMBOLS in `custom-file'.
|
|
|
3495 Leave the point at the end of the file."
|
|
|
3496 (let ((find-file-hooks nil)
|
|
|
3497 (auto-mode-alist nil))
|
|
|
3498 (set-buffer (find-file-noselect custom-file)))
|
|
|
3499 (goto-char (point-min))
|
|
|
3500 (condition-case nil
|
|
|
3501 (while (not (eobp))
|
|
4178
|
3502 (let ((sexp (read (current-buffer))))
|
|
|
3503 (when (and (listp sexp)
|
|
|
3504 (memq (car sexp) symbols))
|
|
|
3505 (delete-region (save-excursion
|
|
|
3506 (backward-sexp)
|
|
|
3507 (point))
|
|
|
3508 (point))
|
|
|
3509 (while (and (eolp) (not (eobp)))
|
|
|
3510 (delete-region (point) (prog2 (forward-line 1) (point))))
|
|
|
3511 )))
|
|
848
|
3512 (end-of-file nil)))
|
|
|
3513
|
|
|
3514 (defsubst custom-save-variable-p (symbol)
|
|
|
3515 "Return non-nil if symbol SYMBOL is a customized variable."
|
|
|
3516 (and (symbolp symbol)
|
|
|
3517 (let ((spec (car-safe (get symbol 'theme-value))))
|
|
4178
|
3518 (or (and spec (eq (car spec) 'user)
|
|
|
3519 (eq (second spec) 'set))
|
|
|
3520 (get symbol 'saved-variable-comment)
|
|
|
3521 ;; support non-themed vars
|
|
|
3522 (and (null spec) (get symbol 'saved-value))))))
|
|
848
|
3523
|
|
|
3524 (defun custom-save-variable-internal (symbol)
|
|
|
3525 "Print variable SYMBOL to the standard output.
|
|
|
3526 SYMBOL must be a customized variable."
|
|
|
3527 (let ((requests (get symbol 'custom-requests))
|
|
4178
|
3528 (now (not (or (get symbol 'standard-value)
|
|
|
3529 (and (not (boundp symbol))
|
|
|
3530 (not (eq (get symbol 'force-value)
|
|
|
3531 'rogue))))))
|
|
|
3532 (comment (get symbol 'saved-variable-comment))
|
|
|
3533 ;; Print everything, no placeholders `...'
|
|
|
3534 (print-level nil)
|
|
|
3535 (print-length nil))
|
|
848
|
3536 (unless (custom-save-variable-p symbol)
|
|
|
3537 (error 'wrong-type-argument "Not a customized variable" symbol))
|
|
|
3538 (princ "\n '(")
|
|
|
3539 (prin1 symbol)
|
|
|
3540 (princ " ")
|
|
|
3541 ;; This comment stuff is in the way ####
|
|
|
3542 ;; Is (eq (third spec) (car saved-value)) ????
|
|
|
3543 ;; (prin1 (third spec))
|
|
|
3544 ;; XEmacs -- pretty-print value if available
|
|
|
3545 (if (and custom-save-pretty-print
|
|
4178
|
3546 (fboundp 'pp))
|
|
|
3547 ;; To suppress bytecompiler warning
|
|
|
3548 (with-fboundp 'pp
|
|
|
3549 (pp (car (get symbol 'saved-value))))
|
|
848
|
3550 (prin1 (car (get symbol 'saved-value))))
|
|
|
3551 (when (or now requests comment)
|
|
|
3552 (princ (if now " t" " nil")))
|
|
|
3553 (when (or comment requests)
|
|
|
3554 (princ " ")
|
|
|
3555 (prin1 requests))
|
|
|
3556 (when comment
|
|
|
3557 (princ " ")
|
|
|
3558 (prin1 comment))
|
|
|
3559 (princ ")")))
|
|
|
3560
|
|
428
|
3561 (defun custom-save-variables ()
|
|
|
3562 "Save all customized variables in `custom-file'."
|
|
|
3563 (save-excursion
|
|
|
3564 (custom-save-delete 'custom-load-themes)
|
|
|
3565 (custom-save-delete 'custom-reset-variables)
|
|
|
3566 (custom-save-delete 'custom-set-variables)
|
|
848
|
3567 ;; This leaves point at the end of file.
|
|
|
3568 ;; Adrian Aichner <adrian@xemacs.org> stated it is
|
|
|
3569 ;; a bad behavior <npak@ispras.ru>
|
|
|
3570 ;;(custom-save-delete-any 'custom-load-themes
|
|
|
3571 ;; 'custom-reset-variables
|
|
|
3572 ;; 'custom-set-variables)
|
|
428
|
3573 (custom-save-loaded-themes)
|
|
|
3574 (custom-save-resets 'theme-value 'custom-reset-variables nil)
|
|
848
|
3575 (let ((standard-output (current-buffer))
|
|
4178
|
3576 (sorted-list ()))
|
|
848
|
3577 ;; First create a sorted list of saved variables.
|
|
|
3578 (mapatoms
|
|
4178
|
3579 (lambda (symbol)
|
|
|
3580 (when (custom-save-variable-p symbol)
|
|
|
3581 (push symbol sorted-list))))
|
|
2122
|
3582 (setq sorted-list (sort sorted-list 'string<))
|
|
428
|
3583 (unless (bolp)
|
|
4178
|
3584 (princ "\n"))
|
|
428
|
3585 (princ "(custom-set-variables")
|
|
848
|
3586 (mapc 'custom-save-variable-internal
|
|
4178
|
3587 sorted-list)
|
|
848
|
3588 (princ ")")
|
|
|
3589 (unless (looking-at "\n")
|
|
4178
|
3590 (princ "\n")))))
|
|
428
|
3591
|
|
|
3592 (defvar custom-save-face-ignoring nil)
|
|
|
3593
|
|
848
|
3594 (defsubst custom-save-face-p (symbol)
|
|
|
3595 "Return non-nil if SYMBOL is a customized face."
|
|
428
|
3596 (let ((theme-spec (car-safe (get symbol 'theme-face)))
|
|
848
|
3597 (comment (get symbol 'saved-face-comment)))
|
|
|
3598 (or (and (not (memq symbol custom-save-face-ignoring))
|
|
4178
|
3599 ;; Don't print default face here.
|
|
|
3600 (or (and theme-spec
|
|
|
3601 (eq (car theme-spec) 'user)
|
|
|
3602 (eq (second theme-spec) 'set))
|
|
|
3603 ;; cope with non-themed faces
|
|
|
3604 (and (null theme-spec)
|
|
|
3605 (get symbol 'saved-face))))
|
|
|
3606 comment)))
|
|
848
|
3607
|
|
|
3608 (defun custom-save-face-internal (symbol)
|
|
|
3609 "Print face SYMBOL to the standard output.
|
|
|
3610 SYMBOL must be a customized face."
|
|
|
3611 (let ((comment (get symbol 'saved-face-comment))
|
|
428
|
3612 (now (not (or (get symbol 'face-defface-spec)
|
|
|
3613 (and (not (find-face symbol))
|
|
848
|
3614 (not (eq (get symbol 'force-face) 'rogue))))))
|
|
4178
|
3615 ;; Print everything, no placeholders `...'
|
|
|
3616 (print-level nil)
|
|
|
3617 (print-length nil))
|
|
848
|
3618 (if (memq symbol custom-save-face-ignoring)
|
|
4178
|
3619 ;; Do nothing
|
|
|
3620 nil
|
|
848
|
3621 ;; Print face
|
|
|
3622 (unless (custom-save-face-p symbol)
|
|
4178
|
3623 (error 'wrong-type-argument "Not a customized face" symbol))
|
|
428
|
3624 (princ "\n '(")
|
|
|
3625 (prin1 symbol)
|
|
|
3626 (princ " ")
|
|
|
3627 (prin1 (get symbol 'saved-face))
|
|
|
3628 (if (or comment now)
|
|
4178
|
3629 (princ (if now " t" " nil")))
|
|
428
|
3630 (when comment
|
|
4178
|
3631 (princ " ")
|
|
|
3632 (prin1 comment))
|
|
428
|
3633 (princ ")"))))
|
|
|
3634
|
|
|
3635 (defun custom-save-faces ()
|
|
|
3636 "Save all customized faces in `custom-file'."
|
|
|
3637 (save-excursion
|
|
|
3638 (custom-save-delete 'custom-reset-faces)
|
|
|
3639 (custom-save-delete 'custom-set-faces)
|
|
848
|
3640 ;; This leaves point at the end of file.
|
|
|
3641 ;; Adrian Aichner <adrian@xemacs.org> stated it is
|
|
|
3642 ;; a bad behavior <npak@ispras.ru>
|
|
|
3643 ;;(custom-save-delete-any 'custom-reset-faces
|
|
|
3644 ;; 'custom-set-faces)
|
|
428
|
3645 (custom-save-resets 'theme-face 'custom-reset-faces '(default))
|
|
848
|
3646 (let ((standard-output (current-buffer))
|
|
4178
|
3647 (sorted-list ()))
|
|
848
|
3648 ;; Create a sorted list of faces
|
|
|
3649 (mapatoms
|
|
|
3650 (lambda (symbol)
|
|
4178
|
3651 (when (custom-save-face-p symbol)
|
|
|
3652 (push symbol sorted-list))))
|
|
2122
|
3653 (setq sorted-list (sort sorted-list 'string<))
|
|
428
|
3654 (unless (bolp)
|
|
|
3655 (princ "\n"))
|
|
|
3656 (princ "(custom-set-faces")
|
|
|
3657 ;; The default face must be first, since it affects the others.
|
|
848
|
3658 (when (custom-save-face-p 'default)
|
|
4178
|
3659 (custom-save-face-internal 'default))
|
|
428
|
3660 (let ((custom-save-face-ignoring '(default)))
|
|
848
|
3661 (mapc 'custom-save-face-internal
|
|
4178
|
3662 sorted-list))
|
|
428
|
3663 (princ ")")
|
|
|
3664 (unless (looking-at "\n")
|
|
|
3665 (princ "\n")))))
|
|
|
3666
|
|
848
|
3667 (defmacro make-custom-save-resets-mapper (property setter)
|
|
|
3668 "Create a mapper for `custom-save-resets'."
|
|
|
3669 `(lambda (object)
|
|
|
3670 (let ((spec (car-safe (get object (quote ,property))))
|
|
4178
|
3671 (print-level nil)
|
|
|
3672 (print-length nil))
|
|
848
|
3673 (with-boundp '(ignored-special started-writing)
|
|
4178
|
3674 (when (and (not (memq object ignored-special))
|
|
|
3675 (eq (car spec) 'user)
|
|
|
3676 (eq (second spec) 'reset))
|
|
|
3677 ;; Do not write reset statements unless necessary.
|
|
|
3678 (unless started-writing
|
|
|
3679 (setq started-writing t)
|
|
|
3680 (unless (bolp)
|
|
|
3681 (princ "\n"))
|
|
|
3682 (princ "(")
|
|
|
3683 (princ (quote ,setter))
|
|
|
3684 (princ "\n '(")
|
|
|
3685 (prin1 object)
|
|
|
3686 (princ " ")
|
|
|
3687 (prin1 (third spec))
|
|
|
3688 (princ ")")))))))
|
|
848
|
3689
|
|
|
3690 (defconst custom-save-resets-mapper-alist
|
|
|
3691 (eval-when-compile
|
|
|
3692 (list (list 'theme-value 'custom-reset-variables
|
|
4178
|
3693 (byte-compile
|
|
|
3694 (make-custom-save-resets-mapper
|
|
|
3695 'theme-value 'custom-reset-variables)))
|
|
|
3696 (list 'theme-face 'custom-reset-faces
|
|
|
3697 (byte-compile
|
|
|
3698 (make-custom-save-resets-mapper
|
|
|
3699 'theme-face 'custom-reset-faces)))))
|
|
848
|
3700 "Never use it.
|
|
|
3701 Hashes several heavily used functions for `custom-save-resets'")
|
|
|
3702
|
|
428
|
3703 (defun custom-save-resets (property setter special)
|
|
848
|
3704 (declare (special ignored-special))
|
|
428
|
3705 (let (started-writing ignored-special)
|
|
444
|
3706 ;; (custom-save-delete setter) Done by caller
|
|
428
|
3707 (let ((standard-output (current-buffer))
|
|
848
|
3708 (mapper (let ((triple (assq property custom-save-resets-mapper-alist)))
|
|
4178
|
3709 (if (and triple (eq (second triple) setter))
|
|
|
3710 (third triple)
|
|
|
3711 (make-custom-save-resets-mapper property setter)))))
|
|
428
|
3712 (mapc mapper special)
|
|
|
3713 (setq ignored-special special)
|
|
|
3714 (mapatoms mapper)
|
|
|
3715 (when started-writing
|
|
848
|
3716 (princ ")\n")))))
|
|
444
|
3717
|
|
428
|
3718
|
|
|
3719 (defun custom-save-loaded-themes ()
|
|
|
3720 (let ((themes (reverse (get 'user 'theme-loads-themes)))
|
|
848
|
3721 (standard-output (current-buffer))
|
|
4178
|
3722 (print-level nil)
|
|
|
3723 (print-length nil))
|
|
428
|
3724 (when themes
|
|
|
3725 (unless (bolp) (princ "\n"))
|
|
|
3726 (princ "(custom-load-themes")
|
|
|
3727 (mapc (lambda (theme)
|
|
|
3728 (princ "\n '")
|
|
|
3729 (prin1 theme)) themes)
|
|
444
|
3730 (princ " )\n"))))
|
|
428
|
3731
|
|
|
3732 ;;;###autoload
|
|
|
3733 (defun customize-save-customized ()
|
|
|
3734 "Save all user options which have been set in this session."
|
|
|
3735 (interactive)
|
|
|
3736 (mapatoms (lambda (symbol)
|
|
|
3737 (let ((face (get symbol 'customized-face))
|
|
|
3738 (value (get symbol 'customized-value))
|
|
|
3739 (face-comment (get symbol 'customized-face-comment))
|
|
|
3740 (variable-comment
|
|
|
3741 (get symbol 'customized-variable-comment)))
|
|
|
3742 (when face
|
|
|
3743 (put symbol 'saved-face face)
|
|
|
3744 (custom-push-theme 'theme-face symbol 'user 'set value)
|
|
|
3745 (put symbol 'customized-face nil))
|
|
|
3746 (when value
|
|
|
3747 (put symbol 'saved-value value)
|
|
|
3748 (custom-push-theme 'theme-value symbol 'user 'set value)
|
|
|
3749 (put symbol 'customized-value nil))
|
|
|
3750 (when variable-comment
|
|
|
3751 (put symbol 'saved-variable-comment variable-comment)
|
|
|
3752 (put symbol 'customized-variable-comment nil))
|
|
|
3753 (when face-comment
|
|
|
3754 (put symbol 'saved-face-comment face-comment)
|
|
|
3755 (put symbol 'customized-face-comment nil)))))
|
|
|
3756 ;; We really should update all custom buffers here.
|
|
|
3757 (custom-save-all))
|
|
|
3758
|
|
|
3759 ;;;###autoload
|
|
|
3760 (defun custom-save-all ()
|
|
|
3761 "Save all customizations in `custom-file'."
|
|
4257
|
3762 (when init-file-had-error
|
|
|
3763 (error 'invalid-change
|
|
|
3764 "Cannot save customizations; init file was not fully loaded"))
|
|
428
|
3765 (let ((inhibit-read-only t))
|
|
|
3766 (custom-save-variables)
|
|
|
3767 (custom-save-faces)
|
|
|
3768 (let ((find-file-hooks nil)
|
|
|
3769 (auto-mode-alist))
|
|
|
3770 (with-current-buffer (find-file-noselect custom-file)
|
|
|
3771 (save-buffer)))))
|
|
|
3772
|
|
|
3773
|
|
|
3774 ;;; The Customize Menu.
|
|
|
3775
|
|
|
3776 ;;; Menu support
|
|
|
3777
|
|
|
3778 (defun custom-face-menu-create (widget symbol)
|
|
|
3779 "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
|
|
|
3780 (vector (custom-unlispify-menu-entry symbol)
|
|
|
3781 `(customize-face ',symbol)
|
|
|
3782 t))
|
|
|
3783
|
|
|
3784 (defun custom-variable-menu-create (widget symbol)
|
|
|
3785 "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
|
|
|
3786 (let ((type (get symbol 'custom-type)))
|
|
|
3787 (unless (listp type)
|
|
|
3788 (setq type (list type)))
|
|
|
3789 (if (and type (widget-get type :custom-menu))
|
|
|
3790 (widget-apply type :custom-menu symbol)
|
|
|
3791 (vector (custom-unlispify-menu-entry symbol)
|
|
|
3792 `(customize-variable ',symbol)
|
|
|
3793 t))))
|
|
|
3794
|
|
|
3795 ;; Add checkboxes to boolean variable entries.
|
|
|
3796 (widget-put (get 'boolean 'widget-type)
|
|
|
3797 :custom-menu (lambda (widget symbol)
|
|
|
3798 `[,(custom-unlispify-menu-entry symbol)
|
|
|
3799 (customize-variable ',symbol)
|
|
|
3800 :style toggle
|
|
|
3801 :selected ,symbol]))
|
|
|
3802
|
|
|
3803 ;; XEmacs can create menus dynamically.
|
|
|
3804 (defun custom-group-menu-create (widget symbol)
|
|
|
3805 "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
|
|
|
3806 `( ,(custom-unlispify-menu-entry symbol t)
|
|
|
3807 :filter (lambda (&rest junk)
|
|
|
3808 (let ((item (custom-menu-create ',symbol)))
|
|
|
3809 (if (listp item)
|
|
|
3810 (cdr item)
|
|
|
3811 (list item))))))
|
|
|
3812
|
|
|
3813 ;;;###autoload
|
|
|
3814 (defun custom-menu-create (symbol)
|
|
|
3815 "Create menu for customization group SYMBOL.
|
|
|
3816 The menu is in a format applicable to `easy-menu-define'."
|
|
2544
|
3817 (menu-split-long-menu
|
|
|
3818 (let* ((item (vector (custom-unlispify-menu-entry symbol)
|
|
|
3819 `(customize-group ',symbol)
|
|
|
3820 t)))
|
|
|
3821 ;; Item is the entry for creating a menu buffer for SYMBOL.
|
|
|
3822 ;; We may nest, if the menu is not too big.
|
|
|
3823 (custom-load-custom-defines symbol)
|
|
|
3824 (if t ;(< (length (get symbol 'custom-group)) widget-menu-max-size)
|
|
|
3825 ;; The menu is not too big.
|
|
|
3826 (let ((custom-prefix-list (custom-prefix-add symbol
|
|
|
3827 custom-prefix-list))
|
|
|
3828 (members (custom-sort-items (get symbol 'custom-group)
|
|
|
3829 custom-menu-sort-alphabetically
|
|
|
3830 custom-menu-order-groups)))
|
|
|
3831 ;; Create the menu.
|
|
|
3832 `(,(custom-unlispify-menu-entry symbol t)
|
|
|
3833 ,item
|
|
|
3834 "--"
|
|
|
3835 ,@(mapcar (lambda (entry)
|
|
|
3836 (widget-apply (if (listp (nth 1 entry))
|
|
|
3837 (nth 1 entry)
|
|
|
3838 (list (nth 1 entry)))
|
|
|
3839 :custom-menu (nth 0 entry)))
|
|
|
3840 members)))
|
|
|
3841 ; else ;; The menu was too big.
|
|
|
3842 item
|
|
|
3843 ))))
|
|
428
|
3844
|
|
|
3845 ;;;###autoload
|
|
|
3846 (defun customize-menu-create (symbol &optional name)
|
|
|
3847 "Return a customize menu for customization group SYMBOL.
|
|
|
3848 If optional NAME is given, use that as the name of the menu.
|
|
|
3849 Otherwise the menu will be named `Customize'.
|
|
|
3850 The format is suitable for use with `easy-menu-define'."
|
|
|
3851 (unless name
|
|
|
3852 (setq name "Customize"))
|
|
|
3853 `(,name
|
|
|
3854 :filter (lambda (&rest junk)
|
|
|
3855 (cdr (custom-menu-create ',symbol)))))
|
|
|
3856
|
|
|
3857 ;;; The Custom Mode.
|
|
|
3858
|
|
|
3859 (defvar custom-mode-map nil
|
|
|
3860 "Keymap for `custom-mode'.")
|
|
|
3861
|
|
|
3862 (unless custom-mode-map
|
|
|
3863 (setq custom-mode-map (make-sparse-keymap))
|
|
|
3864 (set-keymap-parents custom-mode-map widget-keymap)
|
|
|
3865 (suppress-keymap custom-mode-map)
|
|
|
3866 (define-key custom-mode-map " " 'scroll-up)
|
|
|
3867 (define-key custom-mode-map [delete] 'scroll-down)
|
|
|
3868 (define-key custom-mode-map "q" 'Custom-buffer-done)
|
|
|
3869 (define-key custom-mode-map "u" 'Custom-goto-parent)
|
|
|
3870 (define-key custom-mode-map "n" 'widget-forward)
|
|
|
3871 (define-key custom-mode-map "p" 'widget-backward))
|
|
|
3872
|
|
|
3873 (easy-menu-define Custom-mode-menu
|
|
|
3874 custom-mode-map
|
|
|
3875 "Menu used in customization buffers."
|
|
|
3876 `("Custom"
|
|
|
3877 ,(customize-menu-create 'customize)
|
|
|
3878 ["Set" Custom-set t]
|
|
|
3879 ["Save" Custom-save t]
|
|
|
3880 ["Reset to Current" Custom-reset-current t]
|
|
|
3881 ["Reset to Saved" Custom-reset-saved t]
|
|
|
3882 ["Reset to Standard Settings" Custom-reset-standard t]
|
|
|
3883 ["Info" (Info-goto-node "(xemacs)Easy Customization") t]))
|
|
|
3884
|
|
|
3885 (defun Custom-goto-parent ()
|
|
|
3886 "Go to the parent group listed at the top of this buffer.
|
|
|
3887 If several parents are listed, go to the first of them."
|
|
|
3888 (interactive)
|
|
|
3889 (save-excursion
|
|
|
3890 (goto-char (point-min))
|
|
|
3891 (if (search-forward "\nGo to parent group: " nil t)
|
|
|
3892 (let* ((button (get-char-property (point) 'button))
|
|
|
3893 (parent (downcase (widget-get button :tag))))
|
|
|
3894 (customize-group parent)))))
|
|
|
3895
|
|
|
3896 (defcustom custom-mode-hook nil
|
|
|
3897 "Hook called when entering custom-mode."
|
|
|
3898 :type 'hook
|
|
|
3899 :group 'custom-buffer )
|
|
|
3900
|
|
|
3901 (defun custom-state-buffer-message (widget)
|
|
|
3902 (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified)
|
|
|
3903 (message
|
|
|
3904 "To install your edits, invoke [State] and choose the Set operation")))
|
|
|
3905
|
|
|
3906 (defun custom-mode ()
|
|
|
3907 "Major mode for editing customization buffers.
|
|
|
3908
|
|
|
3909 The following commands are available:
|
|
|
3910
|
|
|
3911 Move to next button or editable field. \\[widget-forward]
|
|
|
3912 Move to previous button or editable field. \\[widget-backward]
|
|
|
3913 \\<widget-field-keymap>\
|
|
|
3914 Complete content of editable text field. \\[widget-complete]
|
|
|
3915 \\<custom-mode-map>\
|
|
|
3916 Invoke button under point. \\[widget-button-press]
|
|
|
3917 Set all modifications. \\[Custom-set]
|
|
|
3918 Make all modifications default. \\[Custom-save]
|
|
4178
|
3919 Reset all modified options. \\[Custom-reset-current]
|
|
428
|
3920 Reset all modified or set options. \\[Custom-reset-saved]
|
|
|
3921 Reset all options. \\[Custom-reset-standard]
|
|
|
3922
|
|
|
3923 Entry to this mode calls the value of `custom-mode-hook'
|
|
|
3924 if that value is non-nil."
|
|
|
3925 (kill-all-local-variables)
|
|
|
3926 (setq major-mode 'custom-mode
|
|
|
3927 mode-name "Custom")
|
|
|
3928 (use-local-map custom-mode-map)
|
|
|
3929 (easy-menu-add Custom-mode-menu)
|
|
|
3930 (make-local-variable 'custom-options)
|
|
|
3931 (make-local-variable 'widget-documentation-face)
|
|
|
3932 (setq widget-documentation-face 'custom-documentation-face)
|
|
|
3933 (make-local-variable 'widget-button-face)
|
|
|
3934 (setq widget-button-face 'custom-button-face)
|
|
|
3935 (make-local-hook 'widget-edit-functions)
|
|
|
3936 (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)
|
|
|
3937 (run-hooks 'custom-mode-hook))
|
|
|
3938
|
|
|
3939
|
|
442
|
3940 ;;;###autoload
|
|
|
3941 (defun custom-migrate-custom-file (new-custom-file-name)
|
|
|
3942 "Migrate custom file from home directory."
|
|
|
3943 (mapc 'custom-save-delete
|
|
|
3944 '(custom-load-themes custom-reset-variables
|
|
|
3945 custom-set-variables
|
|
|
3946 custom-set-faces
|
|
|
3947 custom-reset-faces))
|
|
|
3948 (with-current-buffer (find-file-noselect custom-file)
|
|
|
3949 (save-buffer))
|
|
|
3950 (setq custom-file new-custom-file-name)
|
|
|
3951 (custom-save-all))
|
|
|
3952
|
|
428
|
3953 ;;; The End.
|
|
|
3954
|
|
|
3955 (provide 'cus-edit)
|
|
|
3956
|
|
|
3957 ;; cus-edit.el ends here
|
