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