|
28
|
1 ;;; cus-edit.el --- Tools for customization Emacs.
|
|
|
2 ;;
|
|
|
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
|
|
|
4 ;;
|
|
|
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
|
|
|
6 ;; Keywords: help, faces
|
|
167
|
7 ;; Version: 1.9940
|
|
28
|
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
|
|
|
9
|
|
149
|
10 ;; This file is part of GNU Emacs.
|
|
|
11
|
|
|
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
13 ;; it under the terms of the GNU General Public License as published by
|
|
|
14 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
15 ;; any later version.
|
|
|
16
|
|
|
17 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
20 ;; GNU General Public License for more details.
|
|
|
21
|
|
|
22 ;; You should have received a copy of the GNU General Public License
|
|
|
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
25 ;; Boston, MA 02111-1307, USA.
|
|
|
26
|
|
28
|
27 ;;; Commentary:
|
|
|
28 ;;
|
|
149
|
29 ;; This file implements the code to create and edit customize buffers.
|
|
|
30 ;;
|
|
28
|
31 ;; See `custom.el'.
|
|
|
32
|
|
165
|
33 ;; No commands should have names starting with `custom-' because
|
|
|
34 ;; that interferes with completion. Use `customize-' for commands
|
|
|
35 ;; that the user will run with M-x, and `Custom-' for interactive commands.
|
|
|
36
|
|
28
|
37 ;;; Code:
|
|
|
38
|
|
|
39 (require 'cus-face)
|
|
|
40 (require 'wid-edit)
|
|
|
41 (require 'easymenu)
|
|
149
|
42 (eval-when-compile (require 'cl))
|
|
|
43
|
|
|
44 (condition-case nil
|
|
|
45 (require 'cus-load)
|
|
|
46 (error nil))
|
|
28
|
47
|
|
155
|
48 (condition-case nil
|
|
|
49 (require 'cus-start)
|
|
|
50 (error nil))
|
|
|
51
|
|
163
|
52 (define-widget-keywords :custom-last :custom-prefix :custom-category
|
|
|
53 :custom-prefixes :custom-menu
|
|
155
|
54 :custom-show
|
|
28
|
55 :custom-magic :custom-state :custom-level :custom-form
|
|
|
56 :custom-set :custom-save :custom-reset-current :custom-reset-saved
|
|
153
|
57 :custom-reset-standard)
|
|
28
|
58
|
|
120
|
59 (put 'custom-define-hook 'custom-type 'hook)
|
|
153
|
60 (put 'custom-define-hook 'standard-value '(nil))
|
|
120
|
61 (custom-add-to-group 'customize 'custom-define-hook 'custom-variable)
|
|
|
62
|
|
28
|
63 ;;; Customization Groups.
|
|
|
64
|
|
|
65 (defgroup emacs nil
|
|
|
66 "Customization of the One True Editor."
|
|
|
67 :link '(custom-manual "(emacs)Top"))
|
|
|
68
|
|
|
69 ;; Most of these groups are stolen from `finder.el',
|
|
|
70 (defgroup editing nil
|
|
|
71 "Basic text editing facilities."
|
|
|
72 :group 'emacs)
|
|
|
73
|
|
|
74 (defgroup abbrev nil
|
|
|
75 "Abbreviation handling, typing shortcuts, macros."
|
|
|
76 :tag "Abbreviations"
|
|
|
77 :group 'editing)
|
|
|
78
|
|
|
79 (defgroup matching nil
|
|
|
80 "Various sorts of searching and matching."
|
|
|
81 :group 'editing)
|
|
|
82
|
|
|
83 (defgroup emulations nil
|
|
|
84 "Emulations of other editors."
|
|
|
85 :group 'editing)
|
|
|
86
|
|
|
87 (defgroup mouse nil
|
|
|
88 "Mouse support."
|
|
|
89 :group 'editing)
|
|
|
90
|
|
|
91 (defgroup outlines nil
|
|
|
92 "Support for hierarchical outlining."
|
|
|
93 :group 'editing)
|
|
|
94
|
|
|
95 (defgroup external nil
|
|
|
96 "Interfacing to external utilities."
|
|
|
97 :group 'emacs)
|
|
|
98
|
|
|
99 (defgroup bib nil
|
|
|
100 "Code related to the `bib' bibliography processor."
|
|
|
101 :tag "Bibliography"
|
|
|
102 :group 'external)
|
|
|
103
|
|
|
104 (defgroup processes nil
|
|
|
105 "Process, subshell, compilation, and job control support."
|
|
|
106 :group 'external
|
|
|
107 :group 'development)
|
|
|
108
|
|
|
109 (defgroup programming nil
|
|
|
110 "Support for programming in other languages."
|
|
|
111 :group 'emacs)
|
|
|
112
|
|
|
113 (defgroup languages nil
|
|
|
114 "Specialized modes for editing programming languages."
|
|
|
115 :group 'programming)
|
|
|
116
|
|
|
117 (defgroup lisp nil
|
|
|
118 "Lisp support, including Emacs Lisp."
|
|
|
119 :group 'languages
|
|
|
120 :group 'development)
|
|
|
121
|
|
|
122 (defgroup c nil
|
|
|
123 "Support for the C language and related languages."
|
|
|
124 :group 'languages)
|
|
|
125
|
|
|
126 (defgroup tools nil
|
|
|
127 "Programming tools."
|
|
|
128 :group 'programming)
|
|
|
129
|
|
|
130 (defgroup oop nil
|
|
|
131 "Support for object-oriented programming."
|
|
|
132 :group 'programming)
|
|
|
133
|
|
|
134 (defgroup applications nil
|
|
|
135 "Applications written in Emacs."
|
|
|
136 :group 'emacs)
|
|
|
137
|
|
|
138 (defgroup calendar nil
|
|
|
139 "Calendar and time management support."
|
|
|
140 :group 'applications)
|
|
|
141
|
|
|
142 (defgroup mail nil
|
|
|
143 "Modes for electronic-mail handling."
|
|
|
144 :group 'applications)
|
|
|
145
|
|
|
146 (defgroup news nil
|
|
|
147 "Support for netnews reading and posting."
|
|
|
148 :group 'applications)
|
|
|
149
|
|
|
150 (defgroup games nil
|
|
|
151 "Games, jokes and amusements."
|
|
|
152 :group 'applications)
|
|
|
153
|
|
|
154 (defgroup development nil
|
|
|
155 "Support for further development of Emacs."
|
|
|
156 :group 'emacs)
|
|
|
157
|
|
|
158 (defgroup docs nil
|
|
|
159 "Support for Emacs documentation."
|
|
|
160 :group 'development)
|
|
|
161
|
|
|
162 (defgroup extensions nil
|
|
|
163 "Emacs Lisp language extensions."
|
|
|
164 :group 'development)
|
|
|
165
|
|
|
166 (defgroup internal nil
|
|
|
167 "Code for Emacs internals, build process, defaults."
|
|
|
168 :group 'development)
|
|
|
169
|
|
|
170 (defgroup maint nil
|
|
|
171 "Maintenance aids for the Emacs development group."
|
|
|
172 :tag "Maintenance"
|
|
|
173 :group 'development)
|
|
|
174
|
|
|
175 (defgroup environment nil
|
|
|
176 "Fitting Emacs with its environment."
|
|
|
177 :group 'emacs)
|
|
|
178
|
|
|
179 (defgroup comm nil
|
|
|
180 "Communications, networking, remote access to files."
|
|
|
181 :tag "Communication"
|
|
|
182 :group 'environment)
|
|
|
183
|
|
|
184 (defgroup hardware nil
|
|
|
185 "Support for interfacing with exotic hardware."
|
|
|
186 :group 'environment)
|
|
|
187
|
|
|
188 (defgroup terminals nil
|
|
|
189 "Support for terminal types."
|
|
|
190 :group 'environment)
|
|
|
191
|
|
|
192 (defgroup unix nil
|
|
|
193 "Front-ends/assistants for, or emulators of, UNIX features."
|
|
|
194 :group 'environment)
|
|
|
195
|
|
|
196 (defgroup vms nil
|
|
|
197 "Support code for vms."
|
|
|
198 :group 'environment)
|
|
|
199
|
|
|
200 (defgroup i18n nil
|
|
|
201 "Internationalization and alternate character-set support."
|
|
|
202 :group 'environment
|
|
|
203 :group 'editing)
|
|
|
204
|
|
149
|
205 (defgroup x nil
|
|
|
206 "The X Window system."
|
|
|
207 :group 'environment)
|
|
|
208
|
|
28
|
209 (defgroup frames nil
|
|
|
210 "Support for Emacs frames and window systems."
|
|
|
211 :group 'environment)
|
|
|
212
|
|
|
213 (defgroup data nil
|
|
|
214 "Support editing files of data."
|
|
|
215 :group 'emacs)
|
|
|
216
|
|
163
|
217 (defgroup files nil
|
|
|
218 "Support editing files."
|
|
|
219 :group 'emacs)
|
|
|
220
|
|
28
|
221 (defgroup wp nil
|
|
|
222 "Word processing."
|
|
|
223 :group 'emacs)
|
|
|
224
|
|
|
225 (defgroup tex nil
|
|
|
226 "Code related to the TeX formatter."
|
|
|
227 :group 'wp)
|
|
|
228
|
|
|
229 (defgroup faces nil
|
|
|
230 "Support for multiple fonts."
|
|
|
231 :group 'emacs)
|
|
|
232
|
|
|
233 (defgroup hypermedia nil
|
|
|
234 "Support for links between text or other media types."
|
|
|
235 :group 'emacs)
|
|
|
236
|
|
|
237 (defgroup help nil
|
|
|
238 "Support for on-line help systems."
|
|
|
239 :group 'emacs)
|
|
|
240
|
|
|
241 (defgroup local nil
|
|
|
242 "Code local to your site."
|
|
|
243 :group 'emacs)
|
|
|
244
|
|
|
245 (defgroup customize '((widgets custom-group))
|
|
|
246 "Customization of the Customization support."
|
|
|
247 :link '(custom-manual "(custom)Top")
|
|
|
248 :link '(url-link :tag "Development Page"
|
|
|
249 "http://www.dina.kvl.dk/~abraham/custom/")
|
|
|
250 :prefix "custom-"
|
|
124
|
251 :group 'help)
|
|
|
252
|
|
|
253 (defgroup custom-faces nil
|
|
|
254 "Faces used by customize."
|
|
|
255 :group 'customize
|
|
28
|
256 :group 'faces)
|
|
|
257
|
|
165
|
258 (defgroup custom-browse nil
|
|
|
259 "Control customize browser."
|
|
|
260 :prefix "custom-"
|
|
|
261 :group 'customize)
|
|
|
262
|
|
161
|
263 (defgroup custom-buffer nil
|
|
165
|
264 "Control customize buffers."
|
|
161
|
265 :prefix "custom-"
|
|
|
266 :group 'customize)
|
|
|
267
|
|
|
268 (defgroup custom-menu nil
|
|
165
|
269 "Control customize menus."
|
|
161
|
270 :prefix "custom-"
|
|
|
271 :group 'customize)
|
|
|
272
|
|
124
|
273 (defgroup abbrev-mode nil
|
|
|
274 "Word abbreviations mode."
|
|
|
275 :group 'abbrev)
|
|
|
276
|
|
|
277 (defgroup alloc nil
|
|
|
278 "Storage allocation and gc for GNU Emacs Lisp interpreter."
|
|
|
279 :tag "Storage Allocation"
|
|
|
280 :group 'internal)
|
|
|
281
|
|
|
282 (defgroup undo nil
|
|
|
283 "Undoing changes in buffers."
|
|
|
284 :group 'editing)
|
|
|
285
|
|
|
286 (defgroup modeline nil
|
|
|
287 "Content of the modeline."
|
|
|
288 :group 'environment)
|
|
|
289
|
|
|
290 (defgroup fill nil
|
|
|
291 "Indenting and filling text."
|
|
|
292 :group 'editing)
|
|
|
293
|
|
|
294 (defgroup editing-basics nil
|
|
|
295 "Most basic editing facilities."
|
|
|
296 :group 'editing)
|
|
|
297
|
|
|
298 (defgroup display nil
|
|
|
299 "How characters are displayed in buffers."
|
|
|
300 :group 'environment)
|
|
|
301
|
|
|
302 (defgroup execute nil
|
|
|
303 "Executing external commands."
|
|
|
304 :group 'processes)
|
|
|
305
|
|
|
306 (defgroup installation nil
|
|
|
307 "The Emacs installation."
|
|
|
308 :group 'environment)
|
|
|
309
|
|
|
310 (defgroup dired nil
|
|
|
311 "Directory editing."
|
|
|
312 :group 'environment)
|
|
|
313
|
|
|
314 (defgroup limits nil
|
|
|
315 "Internal Emacs limits."
|
|
|
316 :group 'internal)
|
|
|
317
|
|
|
318 (defgroup debug nil
|
|
|
319 "Debugging Emacs itself."
|
|
|
320 :group 'development)
|
|
|
321
|
|
|
322 (defgroup minibuffer nil
|
|
|
323 "Controling the behaviour of the minibuffer."
|
|
|
324 :group 'environment)
|
|
|
325
|
|
|
326 (defgroup keyboard nil
|
|
|
327 "Input from the keyboard."
|
|
|
328 :group 'environment)
|
|
|
329
|
|
|
330 (defgroup mouse nil
|
|
|
331 "Input from the mouse."
|
|
|
332 :group 'environment)
|
|
|
333
|
|
|
334 (defgroup menu nil
|
|
|
335 "Input from the menus."
|
|
|
336 :group 'environment)
|
|
|
337
|
|
|
338 (defgroup auto-save nil
|
|
155
|
339 "Preventing accidential loss of data."
|
|
163
|
340 :group 'files)
|
|
124
|
341
|
|
|
342 (defgroup processes-basics nil
|
|
|
343 "Basic stuff dealing with processes."
|
|
|
344 :group 'processes)
|
|
|
345
|
|
151
|
346 (defgroup mule nil
|
|
|
347 "MULE Emacs internationalization."
|
|
155
|
348 :group 'i18n)
|
|
151
|
349
|
|
153
|
350 (defgroup windows nil
|
|
|
351 "Windows within a frame."
|
|
|
352 :group 'environment)
|
|
|
353
|
|
28
|
354 ;;; Utilities.
|
|
|
355
|
|
163
|
356 (defun custom-last (x &optional n)
|
|
|
357 ;; Stolen from `cl.el'.
|
|
|
358 "Returns the last link in the list LIST.
|
|
|
359 With optional argument N, returns Nth-to-last link (default 1)."
|
|
|
360 (if n
|
|
|
361 (let ((m 0) (p x))
|
|
|
362 (while (consp p) (incf m) (pop p))
|
|
|
363 (if (<= n 0) p
|
|
|
364 (if (< n m) (nthcdr (- m n) x) x)))
|
|
|
365 (while (consp (cdr x)) (pop x))
|
|
|
366 x))
|
|
|
367
|
|
28
|
368 (defun custom-quote (sexp)
|
|
|
369 "Quote SEXP iff it is not self quoting."
|
|
|
370 (if (or (memq sexp '(t nil))
|
|
|
371 (and (symbolp sexp)
|
|
|
372 (eq (aref (symbol-name sexp) 0) ?:))
|
|
|
373 (and (listp sexp)
|
|
|
374 (memq (car sexp) '(lambda)))
|
|
|
375 (stringp sexp)
|
|
|
376 (numberp sexp)
|
|
|
377 (and (fboundp 'characterp)
|
|
|
378 (characterp sexp)))
|
|
|
379 sexp
|
|
|
380 (list 'quote sexp)))
|
|
|
381
|
|
|
382 (defun custom-split-regexp-maybe (regexp)
|
|
|
383 "If REGEXP is a string, split it to a list at `\\|'.
|
|
|
384 You can get the original back with from the result with:
|
|
|
385 (mapconcat 'identity result \"\\|\")
|
|
|
386
|
|
|
387 IF REGEXP is not a string, return it unchanged."
|
|
|
388 (if (stringp regexp)
|
|
|
389 (let ((start 0)
|
|
|
390 all)
|
|
|
391 (while (string-match "\\\\|" regexp start)
|
|
|
392 (setq all (cons (substring regexp start (match-beginning 0)) all)
|
|
|
393 start (match-end 0)))
|
|
|
394 (nreverse (cons (substring regexp start) all)))
|
|
|
395 regexp))
|
|
|
396
|
|
124
|
397 (defun custom-variable-prompt ()
|
|
|
398 ;; Code stolen from `help.el'.
|
|
|
399 "Prompt for a variable, defaulting to the variable at point.
|
|
|
400 Return a list suitable for use in `interactive'."
|
|
|
401 (let ((v (variable-at-point))
|
|
|
402 (enable-recursive-minibuffers t)
|
|
|
403 val)
|
|
|
404 (setq val (completing-read
|
|
155
|
405 (if (symbolp v)
|
|
161
|
406 (format "Customize option: (default %s) " v)
|
|
124
|
407 "Customize variable: ")
|
|
149
|
408 obarray (lambda (symbol)
|
|
|
409 (and (boundp symbol)
|
|
|
410 (or (get symbol 'custom-type)
|
|
|
411 (user-variable-p symbol))))))
|
|
124
|
412 (list (if (equal val "")
|
|
155
|
413 (if (symbolp v) v nil)
|
|
|
414 (intern val)))))
|
|
124
|
415
|
|
149
|
416 (defun custom-menu-filter (menu widget)
|
|
|
417 "Convert MENU to the form used by `widget-choose'.
|
|
|
418 MENU should be in the same format as `custom-variable-menu'.
|
|
|
419 WIDGET is the widget to apply the filter entries of MENU on."
|
|
|
420 (let ((result nil)
|
|
|
421 current name action filter)
|
|
|
422 (while menu
|
|
|
423 (setq current (car menu)
|
|
|
424 name (nth 0 current)
|
|
|
425 action (nth 1 current)
|
|
|
426 filter (nth 2 current)
|
|
|
427 menu (cdr menu))
|
|
|
428 (if (or (null filter) (funcall filter widget))
|
|
|
429 (push (cons name action) result)
|
|
|
430 (push name result)))
|
|
|
431 (nreverse result)))
|
|
|
432
|
|
124
|
433 ;;; Unlispify.
|
|
|
434
|
|
28
|
435 (defvar custom-prefix-list nil
|
|
|
436 "List of prefixes that should be ignored by `custom-unlispify'")
|
|
|
437
|
|
|
438 (defcustom custom-unlispify-menu-entries t
|
|
|
439 "Display menu entries as words instead of symbols if non nil."
|
|
161
|
440 :group 'custom-menu
|
|
28
|
441 :type 'boolean)
|
|
|
442
|
|
|
443 (defun custom-unlispify-menu-entry (symbol &optional no-suffix)
|
|
|
444 "Convert symbol into a menu entry."
|
|
|
445 (cond ((not custom-unlispify-menu-entries)
|
|
|
446 (symbol-name symbol))
|
|
|
447 ((get symbol 'custom-tag)
|
|
|
448 (if no-suffix
|
|
|
449 (get symbol 'custom-tag)
|
|
|
450 (concat (get symbol 'custom-tag) "...")))
|
|
|
451 (t
|
|
|
452 (save-excursion
|
|
|
453 (set-buffer (get-buffer-create " *Custom-Work*"))
|
|
|
454 (erase-buffer)
|
|
|
455 (princ symbol (current-buffer))
|
|
|
456 (goto-char (point-min))
|
|
120
|
457 (when (and (eq (get symbol 'custom-type) 'boolean)
|
|
|
458 (re-search-forward "-p\\'" nil t))
|
|
|
459 (replace-match "" t t)
|
|
|
460 (goto-char (point-min)))
|
|
28
|
461 (let ((prefixes custom-prefix-list)
|
|
|
462 prefix)
|
|
|
463 (while prefixes
|
|
|
464 (setq prefix (car prefixes))
|
|
|
465 (if (search-forward prefix (+ (point) (length prefix)) t)
|
|
|
466 (progn
|
|
|
467 (setq prefixes nil)
|
|
|
468 (delete-region (point-min) (point)))
|
|
|
469 (setq prefixes (cdr prefixes)))))
|
|
|
470 (subst-char-in-region (point-min) (point-max) ?- ?\ t)
|
|
|
471 (capitalize-region (point-min) (point-max))
|
|
|
472 (unless no-suffix
|
|
|
473 (goto-char (point-max))
|
|
|
474 (insert "..."))
|
|
|
475 (buffer-string)))))
|
|
|
476
|
|
|
477 (defcustom custom-unlispify-tag-names t
|
|
|
478 "Display tag names as words instead of symbols if non nil."
|
|
161
|
479 :group 'custom-buffer
|
|
28
|
480 :type 'boolean)
|
|
|
481
|
|
|
482 (defun custom-unlispify-tag-name (symbol)
|
|
|
483 "Convert symbol into a menu entry."
|
|
|
484 (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
|
|
|
485 (custom-unlispify-menu-entry symbol t)))
|
|
|
486
|
|
|
487 (defun custom-prefix-add (symbol prefixes)
|
|
|
488 ;; Addd SYMBOL to list of ignored PREFIXES.
|
|
|
489 (cons (or (get symbol 'custom-prefix)
|
|
|
490 (concat (symbol-name symbol) "-"))
|
|
|
491 prefixes))
|
|
|
492
|
|
124
|
493 ;;; Guess.
|
|
|
494
|
|
|
495 (defcustom custom-guess-name-alist
|
|
120
|
496 '(("-p\\'" boolean)
|
|
|
497 ("-hook\\'" hook)
|
|
|
498 ("-face\\'" face)
|
|
|
499 ("-file\\'" file)
|
|
|
500 ("-function\\'" function)
|
|
|
501 ("-functions\\'" (repeat function))
|
|
|
502 ("-list\\'" (repeat sexp))
|
|
|
503 ("-alist\\'" (repeat (cons sexp sexp))))
|
|
|
504 "Alist of (MATCH TYPE).
|
|
|
505
|
|
|
506 MATCH should be a regexp matching the name of a symbol, and TYPE should
|
|
|
507 be a widget suitable for editing the value of that symbol. The TYPE
|
|
|
508 of the first entry where MATCH matches the name of the symbol will be
|
|
|
509 used.
|
|
|
510
|
|
|
511 This is used for guessing the type of variables not declared with
|
|
|
512 customize."
|
|
124
|
513 :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
|
|
|
514 :group 'customize)
|
|
|
515
|
|
|
516 (defcustom custom-guess-doc-alist
|
|
|
517 '(("\\`\\*?Non-nil " boolean))
|
|
|
518 "Alist of (MATCH TYPE).
|
|
|
519
|
|
|
520 MATCH should be a regexp matching a documentation string, and TYPE
|
|
|
521 should be a widget suitable for editing the value of a variable with
|
|
|
522 that documentation string. The TYPE of the first entry where MATCH
|
|
|
523 matches the name of the symbol will be used.
|
|
|
524
|
|
|
525 This is used for guessing the type of variables not declared with
|
|
|
526 customize."
|
|
|
527 :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
|
|
120
|
528 :group 'customize)
|
|
|
529
|
|
|
530 (defun custom-guess-type (symbol)
|
|
|
531 "Guess a widget suitable for editing the value of SYMBOL.
|
|
124
|
532 This is done by matching SYMBOL with `custom-guess-name-alist' and
|
|
|
533 if that fails, the doc string with `custom-guess-doc-alist'."
|
|
120
|
534 (let ((name (symbol-name symbol))
|
|
124
|
535 (names custom-guess-name-alist)
|
|
120
|
536 current found)
|
|
124
|
537 (while names
|
|
|
538 (setq current (car names)
|
|
|
539 names (cdr names))
|
|
120
|
540 (when (string-match (nth 0 current) name)
|
|
|
541 (setq found (nth 1 current)
|
|
124
|
542 names nil)))
|
|
|
543 (unless found
|
|
|
544 (let ((doc (documentation-property symbol 'variable-documentation))
|
|
|
545 (docs custom-guess-doc-alist))
|
|
|
546 (when doc
|
|
|
547 (while docs
|
|
|
548 (setq current (car docs)
|
|
|
549 docs (cdr docs))
|
|
|
550 (when (string-match (nth 0 current) doc)
|
|
|
551 (setq found (nth 1 current)
|
|
|
552 docs nil))))))
|
|
120
|
553 found))
|
|
|
554
|
|
155
|
555 ;;; Sorting.
|
|
|
556
|
|
165
|
557 (defcustom custom-browse-sort-alphabetically nil
|
|
|
558 "If non-nil, sort members of each customization group alphabetically."
|
|
|
559 :type 'boolean
|
|
|
560 :group 'custom-browse)
|
|
|
561
|
|
|
562 (defcustom custom-browse-order-groups nil
|
|
|
563 "If non-nil, order group members within each customization group.
|
|
|
564 If `first', order groups before non-groups.
|
|
|
565 If `last', order groups after non-groups."
|
|
|
566 :type '(choice (const first)
|
|
|
567 (const last)
|
|
|
568 (const :tag "none" nil))
|
|
|
569 :group 'custom-browse)
|
|
|
570
|
|
167
|
571 (defcustom custom-browse-only-groups nil
|
|
|
572 "If non-nil, show group members only within each customization group."
|
|
|
573 :type 'boolean
|
|
|
574 :group 'custom-browse)
|
|
|
575
|
|
163
|
576 (defcustom custom-buffer-sort-alphabetically nil
|
|
165
|
577 "If non-nil, sort members of each customization group alphabetically."
|
|
163
|
578 :type 'boolean
|
|
161
|
579 :group 'custom-buffer)
|
|
|
580
|
|
165
|
581 (defcustom custom-buffer-order-groups 'last
|
|
|
582 "If non-nil, order group members within each customization group.
|
|
|
583 If `first', order groups before non-groups.
|
|
|
584 If `last', order groups after non-groups."
|
|
|
585 :type '(choice (const first)
|
|
|
586 (const last)
|
|
|
587 (const :tag "none" nil))
|
|
161
|
588 :group 'custom-buffer)
|
|
155
|
589
|
|
163
|
590 (defcustom custom-menu-sort-alphabetically nil
|
|
165
|
591 "If non-nil, sort members of each customization group alphabetically."
|
|
163
|
592 :type 'boolean
|
|
161
|
593 :group 'custom-menu)
|
|
155
|
594
|
|
165
|
595 (defcustom custom-menu-order-groups 'first
|
|
|
596 "If non-nil, order group members within each customization group.
|
|
|
597 If `first', order groups before non-groups.
|
|
|
598 If `last', order groups after non-groups."
|
|
|
599 :type '(choice (const first)
|
|
|
600 (const last)
|
|
|
601 (const :tag "none" nil))
|
|
|
602 :group 'custom-menu)
|
|
155
|
603
|
|
165
|
604 (defun custom-sort-items (items sort-alphabetically order-groups)
|
|
|
605 "Return a sorted copy of ITEMS.
|
|
|
606 ITEMS should be a `custom-group' property.
|
|
|
607 If SORT-ALPHABETICALLY non-nil, sort alphabetically.
|
|
|
608 If ORDER-GROUPS is `first' order groups before non-groups, if `last' order
|
|
|
609 groups after non-groups, if nil do not order groups at all."
|
|
|
610 (sort (copy-sequence items)
|
|
|
611 (lambda (a b)
|
|
|
612 (let ((typea (nth 1 a)) (typeb (nth 1 b))
|
|
|
613 (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b))))
|
|
|
614 (cond ((not order-groups)
|
|
|
615 ;; Since we don't care about A and B order, maybe sort.
|
|
|
616 (when sort-alphabetically
|
|
|
617 (string-lessp namea nameb)))
|
|
|
618 ((eq typea 'custom-group)
|
|
|
619 ;; If B is also a group, maybe sort. Otherwise, order A and B.
|
|
|
620 (if (eq typeb 'custom-group)
|
|
|
621 (when sort-alphabetically
|
|
|
622 (string-lessp namea nameb))
|
|
|
623 (eq order-groups 'first)))
|
|
|
624 ((eq typeb 'custom-group)
|
|
|
625 ;; Since A cannot be a group, order A and B.
|
|
|
626 (eq order-groups 'last))
|
|
|
627 (sort-alphabetically
|
|
|
628 ;; Since A and B cannot be groups, sort.
|
|
|
629 (string-lessp namea nameb)))))))
|
|
155
|
630
|
|
124
|
631 ;;; Custom Mode Commands.
|
|
28
|
632
|
|
|
633 (defvar custom-options nil
|
|
|
634 "Customization widgets in the current buffer.")
|
|
|
635
|
|
165
|
636 (defun Custom-set ()
|
|
28
|
637 "Set changes in all modified options."
|
|
|
638 (interactive)
|
|
|
639 (let ((children custom-options))
|
|
|
640 (mapcar (lambda (child)
|
|
|
641 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
642 (widget-apply child :custom-set)))
|
|
|
643 children)))
|
|
|
644
|
|
165
|
645 (defun Custom-save ()
|
|
28
|
646 "Set all modified group members and save them."
|
|
|
647 (interactive)
|
|
|
648 (let ((children custom-options))
|
|
|
649 (mapcar (lambda (child)
|
|
|
650 (when (memq (widget-get child :custom-state) '(modified set))
|
|
|
651 (widget-apply child :custom-save)))
|
|
|
652 children))
|
|
|
653 (custom-save-all))
|
|
|
654
|
|
|
655 (defvar custom-reset-menu
|
|
165
|
656 '(("Current" . Custom-reset-current)
|
|
|
657 ("Saved" . Custom-reset-saved)
|
|
|
658 ("Standard Settings" . Custom-reset-standard))
|
|
28
|
659 "Alist of actions for the `Reset' button.
|
|
|
660 The key is a string containing the name of the action, the value is a
|
|
|
661 lisp function taking the widget as an element which will be called
|
|
|
662 when the action is chosen.")
|
|
|
663
|
|
|
664 (defun custom-reset (event)
|
|
|
665 "Select item from reset menu."
|
|
|
666 (let* ((completion-ignore-case t)
|
|
|
667 (answer (widget-choose "Reset to"
|
|
|
668 custom-reset-menu
|
|
|
669 event)))
|
|
|
670 (if answer
|
|
|
671 (funcall answer))))
|
|
|
672
|
|
165
|
673 (defun Custom-reset-current (&rest ignore)
|
|
28
|
674 "Reset all modified group members to their current value."
|
|
|
675 (interactive)
|
|
|
676 (let ((children custom-options))
|
|
|
677 (mapcar (lambda (child)
|
|
|
678 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
679 (widget-apply child :custom-reset-current)))
|
|
|
680 children)))
|
|
|
681
|
|
165
|
682 (defun Custom-reset-saved (&rest ignore)
|
|
28
|
683 "Reset all modified or set group members to their saved value."
|
|
|
684 (interactive)
|
|
|
685 (let ((children custom-options))
|
|
|
686 (mapcar (lambda (child)
|
|
|
687 (when (eq (widget-get child :custom-state) 'modified)
|
|
163
|
688 (widget-apply child :custom-reset-saved)))
|
|
28
|
689 children)))
|
|
|
690
|
|
165
|
691 (defun Custom-reset-standard (&rest ignore)
|
|
153
|
692 "Reset all modified, set, or saved group members to their standard settings."
|
|
28
|
693 (interactive)
|
|
|
694 (let ((children custom-options))
|
|
|
695 (mapcar (lambda (child)
|
|
|
696 (when (eq (widget-get child :custom-state) 'modified)
|
|
163
|
697 (widget-apply child :custom-reset-standard)))
|
|
28
|
698 children)))
|
|
|
699
|
|
|
700 ;;; The Customize Commands
|
|
|
701
|
|
149
|
702 (defun custom-prompt-variable (prompt-var prompt-val)
|
|
|
703 "Prompt for a variable and a value and return them as a list.
|
|
|
704 PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the
|
|
|
705 prompt for the value. The %s escape in PROMPT-VAL is replaced with
|
|
|
706 the name of the variable.
|
|
|
707
|
|
|
708 If the variable has a `variable-interactive' property, that is used as if
|
|
|
709 it were the arg to `interactive' (which see) to interactively read the value.
|
|
|
710
|
|
|
711 If the variable has a `custom-type' property, it must be a widget and the
|
|
|
712 `:prompt-value' property of that widget will be used for reading the value."
|
|
|
713 (let* ((var (read-variable prompt-var))
|
|
|
714 (minibuffer-help-form '(describe-variable var)))
|
|
|
715 (list var
|
|
|
716 (let ((prop (get var 'variable-interactive))
|
|
|
717 (type (get var 'custom-type))
|
|
|
718 (prompt (format prompt-val var)))
|
|
|
719 (unless (listp type)
|
|
|
720 (setq type (list type)))
|
|
|
721 (cond (prop
|
|
|
722 ;; Use VAR's `variable-interactive' property
|
|
|
723 ;; as an interactive spec for prompting.
|
|
|
724 (call-interactively (list 'lambda '(arg)
|
|
|
725 (list 'interactive prop)
|
|
|
726 'arg)))
|
|
|
727 (type
|
|
|
728 (widget-prompt-value type
|
|
|
729 prompt
|
|
|
730 (if (boundp var)
|
|
|
731 (symbol-value var))
|
|
|
732 (not (boundp var))))
|
|
|
733 (t
|
|
|
734 (eval-minibuffer prompt)))))))
|
|
|
735
|
|
|
736 ;;;###autoload
|
|
165
|
737 (defun customize-set-value (var val)
|
|
149
|
738 "Set VARIABLE to VALUE. VALUE is a Lisp object.
|
|
|
739
|
|
|
740 If VARIABLE has a `variable-interactive' property, that is used as if
|
|
|
741 it were the arg to `interactive' (which see) to interactively read the value.
|
|
|
742
|
|
|
743 If VARIABLE has a `custom-type' property, it must be a widget and the
|
|
|
744 `:prompt-value' property of that widget will be used for reading the value."
|
|
|
745 (interactive (custom-prompt-variable "Set variable: "
|
|
|
746 "Set %s to value: "))
|
|
|
747
|
|
|
748 (set var val))
|
|
|
749
|
|
|
750 ;;;###autoload
|
|
165
|
751 (defun customize-set-variable (var val)
|
|
149
|
752 "Set the default for VARIABLE to VALUE. VALUE is a Lisp object.
|
|
|
753
|
|
|
754 If VARIABLE has a `custom-set' property, that is used for setting
|
|
|
755 VARIABLE, otherwise `set-default' is used.
|
|
|
756
|
|
|
757 The `customized-value' property of the VARIABLE will be set to a list
|
|
|
758 with a quoted VALUE as its sole list member.
|
|
|
759
|
|
|
760 If VARIABLE has a `variable-interactive' property, that is used as if
|
|
|
761 it were the arg to `interactive' (which see) to interactively read the value.
|
|
|
762
|
|
|
763 If VARIABLE has a `custom-type' property, it must be a widget and the
|
|
|
764 `:prompt-value' property of that widget will be used for reading the value. "
|
|
|
765 (interactive (custom-prompt-variable "Set variable: "
|
|
|
766 "Set customized value for %s to: "))
|
|
|
767 (funcall (or (get var 'custom-set) 'set-default) var val)
|
|
|
768 (put var 'customized-value (list (custom-quote val))))
|
|
|
769
|
|
28
|
770 ;;;###autoload
|
|
153
|
771 (defun customize ()
|
|
|
772 "Select a customization buffer which you can use to set user options.
|
|
|
773 User options are structured into \"groups\".
|
|
|
774 Initially the top-level group `Emacs' and its immediate subgroups
|
|
|
775 are shown; the contents of those subgroups are initially hidden."
|
|
|
776 (interactive)
|
|
|
777 (customize-group 'emacs))
|
|
|
778
|
|
|
779 ;;;###autoload
|
|
|
780 (defun customize-group (group)
|
|
|
781 "Customize GROUP, which must be a customization group."
|
|
163
|
782 (interactive (list (let ((completion-ignore-case t))
|
|
|
783 (completing-read "Customize group: (default emacs) "
|
|
|
784 obarray
|
|
|
785 (lambda (symbol)
|
|
|
786 (get symbol 'custom-group))
|
|
|
787 t))))
|
|
28
|
788
|
|
153
|
789 (when (stringp group)
|
|
|
790 (if (string-equal "" group)
|
|
|
791 (setq group 'emacs)
|
|
|
792 (setq group (intern group))))
|
|
163
|
793 (let ((name (format "*Customize Group: %s*"
|
|
|
794 (custom-unlispify-tag-name group))))
|
|
|
795 (if (get-buffer name)
|
|
|
796 (switch-to-buffer name)
|
|
|
797 (custom-buffer-create (list (list group 'custom-group))
|
|
|
798 name))))
|
|
149
|
799
|
|
|
800 ;;;###autoload
|
|
153
|
801 (defun customize-group-other-window (symbol)
|
|
149
|
802 "Customize SYMBOL, which must be a customization group."
|
|
|
803 (interactive (list (completing-read "Customize group: (default emacs) "
|
|
|
804 obarray
|
|
|
805 (lambda (symbol)
|
|
|
806 (get symbol 'custom-group))
|
|
|
807 t)))
|
|
|
808
|
|
|
809 (when (stringp symbol)
|
|
|
810 (if (string-equal "" symbol)
|
|
|
811 (setq symbol 'emacs)
|
|
|
812 (setq symbol (intern symbol))))
|
|
|
813 (custom-buffer-create-other-window
|
|
|
814 (list (list symbol 'custom-group))
|
|
|
815 (format "*Customize Group: %s*" (custom-unlispify-tag-name symbol))))
|
|
28
|
816
|
|
|
817 ;;;###autoload
|
|
155
|
818 (defalias 'customize-variable 'customize-option)
|
|
|
819
|
|
|
820 ;;;###autoload
|
|
|
821 (defun customize-option (symbol)
|
|
|
822 "Customize SYMBOL, which must be a user option variable."
|
|
124
|
823 (interactive (custom-variable-prompt))
|
|
149
|
824 (custom-buffer-create (list (list symbol 'custom-variable))
|
|
155
|
825 (format "*Customize Option: %s*"
|
|
149
|
826 (custom-unlispify-tag-name symbol))))
|
|
28
|
827
|
|
|
828 ;;;###autoload
|
|
155
|
829 (defalias 'customize-variable-other-window 'customize-option-other-window)
|
|
|
830
|
|
|
831 ;;;###autoload
|
|
|
832 (defun customize-option-other-window (symbol)
|
|
|
833 "Customize SYMBOL, which must be a user option variable.
|
|
124
|
834 Show the buffer in another window, but don't select it."
|
|
|
835 (interactive (custom-variable-prompt))
|
|
149
|
836 (custom-buffer-create-other-window
|
|
|
837 (list (list symbol 'custom-variable))
|
|
155
|
838 (format "*Customize Option: %s*" (custom-unlispify-tag-name symbol))))
|
|
124
|
839
|
|
|
840 ;;;###autoload
|
|
28
|
841 (defun customize-face (&optional symbol)
|
|
|
842 "Customize SYMBOL, which should be a face name or nil.
|
|
|
843 If SYMBOL is nil, customize all faces."
|
|
|
844 (interactive (list (completing-read "Customize face: (default all) "
|
|
|
845 obarray 'custom-facep)))
|
|
|
846 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
|
|
165
|
847 (custom-buffer-create (custom-sort-items
|
|
|
848 (mapcar (lambda (symbol)
|
|
|
849 (list symbol 'custom-face))
|
|
|
850 (face-list))
|
|
|
851 t nil)
|
|
|
852 "*Customize Faces*")
|
|
|
853 (when (stringp symbol)
|
|
|
854 (setq symbol (intern symbol)))
|
|
28
|
855 (unless (symbolp symbol)
|
|
|
856 (error "Should be a symbol %S" symbol))
|
|
149
|
857 (custom-buffer-create (list (list symbol 'custom-face))
|
|
|
858 (format "*Customize Face: %s*"
|
|
|
859 (custom-unlispify-tag-name symbol)))))
|
|
28
|
860
|
|
|
861 ;;;###autoload
|
|
124
|
862 (defun customize-face-other-window (&optional symbol)
|
|
|
863 "Show customization buffer for FACE in other window."
|
|
|
864 (interactive (list (completing-read "Customize face: "
|
|
|
865 obarray 'custom-facep)))
|
|
|
866 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
|
|
|
867 ()
|
|
|
868 (if (stringp symbol)
|
|
|
869 (setq symbol (intern symbol)))
|
|
|
870 (unless (symbolp symbol)
|
|
|
871 (error "Should be a symbol %S" symbol))
|
|
149
|
872 (custom-buffer-create-other-window
|
|
|
873 (list (list symbol 'custom-face))
|
|
|
874 (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol)))))
|
|
124
|
875
|
|
|
876 ;;;###autoload
|
|
28
|
877 (defun customize-customized ()
|
|
149
|
878 "Customize all user options set since the last save in this session."
|
|
|
879 (interactive)
|
|
|
880 (let ((found nil))
|
|
|
881 (mapatoms (lambda (symbol)
|
|
167
|
882 (and (condition-case nil
|
|
|
883 (get symbol 'customized-face)
|
|
|
884 (t (progn
|
|
|
885 (message "Bad plist in %s"
|
|
|
886 (symbol-name symbol))
|
|
|
887 nil)))
|
|
149
|
888 (custom-facep symbol)
|
|
163
|
889 (push (list symbol 'custom-face) found))
|
|
149
|
890 (and (get symbol 'customized-value)
|
|
|
891 (boundp symbol)
|
|
163
|
892 (push (list symbol 'custom-variable) found))))
|
|
165
|
893 (if (not found)
|
|
|
894 (error "No customized user options")
|
|
|
895 (custom-buffer-create (custom-sort-items found t nil)
|
|
|
896 "*Customize Customized*"))))
|
|
149
|
897
|
|
|
898 ;;;###autoload
|
|
|
899 (defun customize-saved ()
|
|
|
900 "Customize all already saved user options."
|
|
28
|
901 (interactive)
|
|
|
902 (let ((found nil))
|
|
|
903 (mapatoms (lambda (symbol)
|
|
167
|
904 (and (condition-case nil
|
|
|
905 (get symbol 'saved-face)
|
|
|
906 (t (progn
|
|
|
907 (message "Bad plist in %s"
|
|
|
908 (symbol-name symbol))
|
|
|
909 nil)))
|
|
28
|
910 (custom-facep symbol)
|
|
163
|
911 (push (list symbol 'custom-face) found))
|
|
28
|
912 (and (get symbol 'saved-value)
|
|
|
913 (boundp symbol)
|
|
163
|
914 (push (list symbol 'custom-variable) found))))
|
|
165
|
915 (if (not found )
|
|
|
916 (error "No saved user options")
|
|
|
917 (custom-buffer-create (custom-sort-items found t nil)
|
|
|
918 "*Customize Saved*"))))
|
|
28
|
919
|
|
|
920 ;;;###autoload
|
|
|
921 (defun customize-apropos (regexp &optional all)
|
|
|
922 "Customize all user options matching REGEXP.
|
|
163
|
923 If ALL is `options', include only options.
|
|
|
924 If ALL is `faces', include only faces.
|
|
|
925 If ALL is `groups', include only groups.
|
|
|
926 If ALL is t (interactively, with prefix arg), include options which are not
|
|
|
927 user-settable, as well as faces and groups."
|
|
28
|
928 (interactive "sCustomize regexp: \nP")
|
|
|
929 (let ((found nil))
|
|
|
930 (mapatoms (lambda (symbol)
|
|
|
931 (when (string-match regexp (symbol-name symbol))
|
|
163
|
932 (when (and (not (memq all '(faces options)))
|
|
|
933 (get symbol 'custom-group))
|
|
|
934 (push (list symbol 'custom-group) found))
|
|
|
935 (when (and (not (memq all '(options groups)))
|
|
|
936 (custom-facep symbol))
|
|
|
937 (push (list symbol 'custom-face) found))
|
|
|
938 (when (and (not (memq all '(groups faces)))
|
|
|
939 (boundp symbol)
|
|
28
|
940 (or (get symbol 'saved-value)
|
|
153
|
941 (get symbol 'standard-value)
|
|
163
|
942 (if (memq all '(nil options))
|
|
|
943 (user-variable-p symbol)
|
|
|
944 (get symbol 'variable-documentation))))
|
|
|
945 (push (list symbol 'custom-variable) found)))))
|
|
|
946 (if (not found)
|
|
|
947 (error "No matches")
|
|
165
|
948 (custom-buffer-create (custom-sort-items found t
|
|
|
949 custom-buffer-order-groups)
|
|
|
950 "*Customize Apropos*"))))
|
|
163
|
951
|
|
|
952 ;;;###autoload
|
|
|
953 (defun customize-apropos-options (regexp &optional arg)
|
|
|
954 "Customize all user options matching REGEXP.
|
|
|
955 With prefix arg, include options which are not user-settable."
|
|
|
956 (interactive "sCustomize regexp: \nP")
|
|
|
957 (customize-apropos regexp (or arg 'options)))
|
|
|
958
|
|
|
959 ;;;###autoload
|
|
|
960 (defun customize-apropos-faces (regexp)
|
|
|
961 "Customize all user faces matching REGEXP."
|
|
|
962 (interactive "sCustomize regexp: \n")
|
|
|
963 (customize-apropos regexp 'faces))
|
|
|
964
|
|
|
965 ;;;###autoload
|
|
|
966 (defun customize-apropos-groups (regexp)
|
|
|
967 "Customize all user groups matching REGEXP."
|
|
|
968 (interactive "sCustomize regexp: \n")
|
|
|
969 (customize-apropos regexp 'groups))
|
|
28
|
970
|
|
149
|
971 ;;; Buffer.
|
|
|
972
|
|
163
|
973 (defcustom custom-buffer-style 'links
|
|
|
974 "Control the presentation style for customization buffers.
|
|
|
975 The value should be a symbol, one of:
|
|
|
976
|
|
|
977 brackets: groups nest within each other with big horizontal brackets.
|
|
|
978 links: groups have links to subgroups."
|
|
|
979 :type '(radio (const brackets)
|
|
|
980 (const links))
|
|
|
981 :group 'custom-buffer)
|
|
|
982
|
|
|
983 (defcustom custom-buffer-indent 3
|
|
|
984 "Number of spaces to indent nested groups."
|
|
|
985 :type 'integer
|
|
|
986 :group 'custom-buffer)
|
|
|
987
|
|
28
|
988 ;;;###autoload
|
|
149
|
989 (defun custom-buffer-create (options &optional name)
|
|
28
|
990 "Create a buffer containing OPTIONS.
|
|
149
|
991 Optional NAME is the name of the buffer.
|
|
28
|
992 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
|
|
|
993 SYMBOL is a customization option, and WIDGET is a widget for editing
|
|
|
994 that option."
|
|
149
|
995 (unless name (setq name "*Customization*"))
|
|
|
996 (kill-buffer (get-buffer-create name))
|
|
|
997 (switch-to-buffer (get-buffer-create name))
|
|
124
|
998 (custom-buffer-create-internal options))
|
|
|
999
|
|
149
|
1000 ;;;###autoload
|
|
|
1001 (defun custom-buffer-create-other-window (options &optional name)
|
|
124
|
1002 "Create a buffer containing OPTIONS.
|
|
149
|
1003 Optional NAME is the name of the buffer.
|
|
124
|
1004 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
|
|
|
1005 SYMBOL is a customization option, and WIDGET is a widget for editing
|
|
|
1006 that option."
|
|
149
|
1007 (unless name (setq name "*Customization*"))
|
|
|
1008 (kill-buffer (get-buffer-create name))
|
|
124
|
1009 (let ((window (selected-window)))
|
|
149
|
1010 (switch-to-buffer-other-window (get-buffer-create name))
|
|
124
|
1011 (custom-buffer-create-internal options)
|
|
|
1012 (select-window window)))
|
|
155
|
1013
|
|
|
1014 (defcustom custom-reset-button-menu nil
|
|
|
1015 "If non-nil, only show a single reset button in customize buffers.
|
|
|
1016 This button will have a menu with all three reset operations."
|
|
|
1017 :type 'boolean
|
|
161
|
1018 :group 'custom-buffer)
|
|
124
|
1019
|
|
|
1020 (defun custom-buffer-create-internal (options)
|
|
|
1021 (message "Creating customization buffer...")
|
|
28
|
1022 (custom-mode)
|
|
|
1023 (widget-insert "This is a customization buffer.
|
|
165
|
1024 Square brackets show active fields; type RET or click mouse-2
|
|
|
1025 on an active field to invoke its action. Invoke ")
|
|
28
|
1026 (widget-create 'info-link
|
|
165
|
1027 :tag "Help"
|
|
30
|
1028 :help-echo "Read the online help."
|
|
155
|
1029 "(emacs)Easy Customization")
|
|
28
|
1030 (widget-insert " for more information.\n\n")
|
|
153
|
1031 (message "Creating customization buttons...")
|
|
165
|
1032 (widget-insert "Operate on everything in this buffer:\n ")
|
|
153
|
1033 (widget-create 'push-button
|
|
|
1034 :tag "Set"
|
|
165
|
1035 :help-echo "\
|
|
|
1036 Make your editing in this buffer take effect for this session."
|
|
153
|
1037 :action (lambda (widget &optional event)
|
|
165
|
1038 (Custom-set)))
|
|
153
|
1039 (widget-insert " ")
|
|
|
1040 (widget-create 'push-button
|
|
|
1041 :tag "Save"
|
|
|
1042 :help-echo "\
|
|
165
|
1043 Make your editing in this buffer take effect for future Emacs sessions."
|
|
153
|
1044 :action (lambda (widget &optional event)
|
|
165
|
1045 (Custom-save)))
|
|
153
|
1046 (widget-insert " ")
|
|
155
|
1047 (if custom-reset-button-menu
|
|
|
1048 (widget-create 'push-button
|
|
|
1049 :tag "Reset"
|
|
|
1050 :help-echo "Show a menu with reset operations."
|
|
|
1051 :mouse-down-action (lambda (&rest junk) t)
|
|
|
1052 :action (lambda (widget &optional event)
|
|
|
1053 (custom-reset event)))
|
|
|
1054 (widget-create 'push-button
|
|
|
1055 :tag "Reset"
|
|
|
1056 :help-echo "\
|
|
165
|
1057 Reset all edited text in this buffer to reflect current values."
|
|
|
1058 :action 'Custom-reset-current)
|
|
155
|
1059 (widget-insert " ")
|
|
|
1060 (widget-create 'push-button
|
|
|
1061 :tag "Reset to Saved"
|
|
|
1062 :help-echo "\
|
|
165
|
1063 Reset all values in this buffer to their saved settings."
|
|
|
1064 :action 'Custom-reset-saved)
|
|
155
|
1065 (widget-insert " ")
|
|
|
1066 (widget-create 'push-button
|
|
|
1067 :tag "Reset to Standard"
|
|
|
1068 :help-echo "\
|
|
165
|
1069 Reset all values in this buffer to their standard settings."
|
|
|
1070 :action 'Custom-reset-standard))
|
|
|
1071 (widget-insert " ")
|
|
153
|
1072 (widget-create 'push-button
|
|
165
|
1073 :tag "Bury Buffer"
|
|
153
|
1074 :help-echo "Bury the buffer."
|
|
|
1075 :action (lambda (widget &optional event)
|
|
|
1076 (bury-buffer)))
|
|
|
1077 (widget-insert "\n\n")
|
|
|
1078 (message "Creating customization items...")
|
|
28
|
1079 (setq custom-options
|
|
120
|
1080 (if (= (length options) 1)
|
|
|
1081 (mapcar (lambda (entry)
|
|
|
1082 (widget-create (nth 1 entry)
|
|
157
|
1083 :documentation-shown t
|
|
120
|
1084 :custom-state 'unknown
|
|
|
1085 :tag (custom-unlispify-tag-name
|
|
|
1086 (nth 0 entry))
|
|
|
1087 :value (nth 0 entry)))
|
|
|
1088 options)
|
|
|
1089 (let ((count 0)
|
|
|
1090 (length (length options)))
|
|
|
1091 (mapcar (lambda (entry)
|
|
|
1092 (prog2
|
|
|
1093 (message "Creating customization items %2d%%..."
|
|
|
1094 (/ (* 100.0 count) length))
|
|
|
1095 (widget-create (nth 1 entry)
|
|
28
|
1096 :tag (custom-unlispify-tag-name
|
|
|
1097 (nth 0 entry))
|
|
|
1098 :value (nth 0 entry))
|
|
120
|
1099 (setq count (1+ count))
|
|
|
1100 (unless (eq (preceding-char) ?\n)
|
|
|
1101 (widget-insert "\n"))
|
|
|
1102 (widget-insert "\n")))
|
|
|
1103 options))))
|
|
|
1104 (unless (eq (preceding-char) ?\n)
|
|
|
1105 (widget-insert "\n"))
|
|
163
|
1106 (unless (eq custom-buffer-style 'tree)
|
|
|
1107 (mapcar 'custom-magic-reset custom-options))
|
|
120
|
1108 (message "Creating customization setup...")
|
|
30
|
1109 (widget-setup)
|
|
120
|
1110 (goto-char (point-min))
|
|
|
1111 (message "Creating customization buffer...done"))
|
|
28
|
1112
|
|
163
|
1113 ;;; The Tree Browser.
|
|
|
1114
|
|
|
1115 ;;;###autoload
|
|
165
|
1116 (defun customize-browse (group)
|
|
163
|
1117 "Create a tree browser for the customize hierarchy."
|
|
165
|
1118 (interactive (list (let ((completion-ignore-case t))
|
|
|
1119 (completing-read "Customize group: (default emacs) "
|
|
|
1120 obarray
|
|
|
1121 (lambda (symbol)
|
|
|
1122 (get symbol 'custom-group))
|
|
|
1123 t))))
|
|
|
1124
|
|
|
1125 (when (stringp group)
|
|
|
1126 (if (string-equal "" group)
|
|
|
1127 (setq group 'emacs)
|
|
|
1128 (setq group (intern group))))
|
|
163
|
1129 (let ((name "*Customize Browser*"))
|
|
|
1130 (kill-buffer (get-buffer-create name))
|
|
|
1131 (switch-to-buffer (get-buffer-create name)))
|
|
|
1132 (custom-mode)
|
|
|
1133 (widget-insert "\
|
|
167
|
1134 Invoke [+] or [?] below to expand items, and [-] to collapse items.
|
|
165
|
1135 Invoke the [Group], [Face], and [Option] buttons below to edit that
|
|
163
|
1136 item in another window.\n\n")
|
|
|
1137 (let ((custom-buffer-style 'tree))
|
|
|
1138 (widget-create 'custom-group
|
|
|
1139 :custom-last t
|
|
|
1140 :custom-state 'unknown
|
|
165
|
1141 :tag (custom-unlispify-tag-name group)
|
|
|
1142 :value group))
|
|
163
|
1143 (goto-char (point-min)))
|
|
|
1144
|
|
167
|
1145 (define-widget 'custom-browse-visibility 'item
|
|
163
|
1146 "Control visibility of of items in the customize tree browser."
|
|
|
1147 :format "%[[%t]%]"
|
|
167
|
1148 :action 'custom-browse-visibility-action)
|
|
|
1149
|
|
|
1150 (defun custom-browse-visibility-action (widget &rest ignore)
|
|
163
|
1151 (let ((custom-buffer-style 'tree))
|
|
|
1152 (custom-toggle-parent widget)))
|
|
|
1153
|
|
167
|
1154 (define-widget 'custom-browse-group-tag 'push-button
|
|
163
|
1155 "Show parent in other window when activated."
|
|
165
|
1156 :tag "Group"
|
|
163
|
1157 :tag-glyph "folder"
|
|
167
|
1158 :action 'custom-browse-group-tag-action)
|
|
|
1159
|
|
|
1160 (defun custom-browse-group-tag-action (widget &rest ignore)
|
|
163
|
1161 (let ((parent (widget-get widget :parent)))
|
|
|
1162 (customize-group-other-window (widget-value parent))))
|
|
|
1163
|
|
167
|
1164 (define-widget 'custom-browse-variable-tag 'push-button
|
|
163
|
1165 "Show parent in other window when activated."
|
|
165
|
1166 :tag "Option"
|
|
163
|
1167 :tag-glyph "option"
|
|
167
|
1168 :action 'custom-browse-variable-tag-action)
|
|
|
1169
|
|
|
1170 (defun custom-browse-variable-tag-action (widget &rest ignore)
|
|
163
|
1171 (let ((parent (widget-get widget :parent)))
|
|
|
1172 (customize-variable-other-window (widget-value parent))))
|
|
|
1173
|
|
167
|
1174 (define-widget 'custom-browse-face-tag 'push-button
|
|
163
|
1175 "Show parent in other window when activated."
|
|
165
|
1176 :tag "Face"
|
|
163
|
1177 :tag-glyph "face"
|
|
167
|
1178 :action 'custom-browse-face-tag-action)
|
|
|
1179
|
|
|
1180 (defun custom-browse-face-tag-action (widget &rest ignore)
|
|
163
|
1181 (let ((parent (widget-get widget :parent)))
|
|
|
1182 (customize-face-other-window (widget-value parent))))
|
|
|
1183
|
|
167
|
1184 (defconst custom-browse-alist '((" " "space")
|
|
163
|
1185 (" | " "vertical")
|
|
165
|
1186 ("-\\ " "top")
|
|
163
|
1187 (" |-" "middle")
|
|
|
1188 (" `-" "bottom")))
|
|
|
1189
|
|
167
|
1190 (defun custom-browse-insert-prefix (prefix)
|
|
163
|
1191 "Insert PREFIX. On XEmacs convert it to line graphics."
|
|
165
|
1192 (if nil ; (string-match "XEmacs" emacs-version)
|
|
|
1193 (progn
|
|
|
1194 (insert "*")
|
|
|
1195 (while (not (string-equal prefix ""))
|
|
|
1196 (let ((entry (substring prefix 0 3)))
|
|
|
1197 (setq prefix (substring prefix 3))
|
|
|
1198 (let ((overlay (make-overlay (1- (point)) (point) nil t nil))
|
|
167
|
1199 (name (nth 1 (assoc entry custom-browse-alist))))
|
|
165
|
1200 (overlay-put overlay 'end-glyph (widget-glyph-find name entry))
|
|
|
1201 (overlay-put overlay 'start-open t)
|
|
|
1202 (overlay-put overlay 'end-open t)))))
|
|
163
|
1203 (insert prefix)))
|
|
|
1204
|
|
28
|
1205 ;;; Modification of Basic Widgets.
|
|
|
1206 ;;
|
|
|
1207 ;; We add extra properties to the basic widgets needed here. This is
|
|
|
1208 ;; fine, as long as we are careful to stay within out own namespace.
|
|
|
1209 ;;
|
|
|
1210 ;; We want simple widgets to be displayed by default, but complex
|
|
|
1211 ;; widgets to be hidden.
|
|
|
1212
|
|
|
1213 (widget-put (get 'item 'widget-type) :custom-show t)
|
|
|
1214 (widget-put (get 'editable-field 'widget-type)
|
|
|
1215 :custom-show (lambda (widget value)
|
|
|
1216 (let ((pp (pp-to-string value)))
|
|
|
1217 (cond ((string-match "\n" pp)
|
|
|
1218 nil)
|
|
|
1219 ((> (length pp) 40)
|
|
|
1220 nil)
|
|
|
1221 (t t)))))
|
|
|
1222 (widget-put (get 'menu-choice 'widget-type) :custom-show t)
|
|
|
1223
|
|
|
1224 ;;; The `custom-manual' Widget.
|
|
|
1225
|
|
|
1226 (define-widget 'custom-manual 'info-link
|
|
|
1227 "Link to the manual entry for this customization option."
|
|
30
|
1228 :help-echo "Read the manual entry for this option."
|
|
28
|
1229 :tag "Manual")
|
|
|
1230
|
|
|
1231 ;;; The `custom-magic' Widget.
|
|
|
1232
|
|
161
|
1233 (defgroup custom-magic-faces nil
|
|
|
1234 "Faces used by the magic button."
|
|
|
1235 :group 'custom-faces
|
|
|
1236 :group 'custom-buffer)
|
|
|
1237
|
|
28
|
1238 (defface custom-invalid-face '((((class color))
|
|
|
1239 (:foreground "yellow" :background "red"))
|
|
|
1240 (t
|
|
|
1241 (:bold t :italic t :underline t)))
|
|
161
|
1242 "Face used when the customize item is invalid."
|
|
|
1243 :group 'custom-magic-faces)
|
|
28
|
1244
|
|
|
1245 (defface custom-rogue-face '((((class color))
|
|
|
1246 (:foreground "pink" :background "black"))
|
|
|
1247 (t
|
|
|
1248 (:underline t)))
|
|
161
|
1249 "Face used when the customize item is not defined for customization."
|
|
|
1250 :group 'custom-magic-faces)
|
|
28
|
1251
|
|
|
1252 (defface custom-modified-face '((((class color))
|
|
|
1253 (:foreground "white" :background "blue"))
|
|
|
1254 (t
|
|
|
1255 (:italic t :bold)))
|
|
161
|
1256 "Face used when the customize item has been modified."
|
|
|
1257 :group 'custom-magic-faces)
|
|
28
|
1258
|
|
|
1259 (defface custom-set-face '((((class color))
|
|
|
1260 (:foreground "blue" :background "white"))
|
|
|
1261 (t
|
|
|
1262 (:italic t)))
|
|
161
|
1263 "Face used when the customize item has been set."
|
|
|
1264 :group 'custom-magic-faces)
|
|
28
|
1265
|
|
|
1266 (defface custom-changed-face '((((class color))
|
|
|
1267 (:foreground "white" :background "blue"))
|
|
|
1268 (t
|
|
|
1269 (:italic t)))
|
|
161
|
1270 "Face used when the customize item has been changed."
|
|
|
1271 :group 'custom-magic-faces)
|
|
28
|
1272
|
|
|
1273 (defface custom-saved-face '((t (:underline t)))
|
|
161
|
1274 "Face used when the customize item has been saved."
|
|
|
1275 :group 'custom-magic-faces)
|
|
28
|
1276
|
|
153
|
1277 (defconst custom-magic-alist '((nil "#" underline "\
|
|
28
|
1278 uninitialized, you should not see this.")
|
|
153
|
1279 (unknown "?" italic "\
|
|
28
|
1280 unknown, you should not see this.")
|
|
153
|
1281 (hidden "-" default "\
|
|
163
|
1282 hidden, invoke \"Show\" in the previous line to show." "\
|
|
|
1283 group now hidden, invoke \"Show\", above, to show contents.")
|
|
153
|
1284 (invalid "x" custom-invalid-face "\
|
|
155
|
1285 the value displayed for this %c is invalid and cannot be set.")
|
|
153
|
1286 (modified "*" custom-modified-face "\
|
|
155
|
1287 you have edited the value, and can now set the %c." "\
|
|
153
|
1288 you have edited something in this group, and can now set it.")
|
|
|
1289 (set "+" custom-set-face "\
|
|
155
|
1290 you have set this %c, but not saved it." "\
|
|
153
|
1291 something in this group has been set, but not yet saved.")
|
|
|
1292 (changed ":" custom-changed-face "\
|
|
155
|
1293 this %c has been changed outside the customize buffer." "\
|
|
153
|
1294 something in this group has been changed outside customize.")
|
|
|
1295 (saved "!" custom-saved-face "\
|
|
155
|
1296 this %c has been set and saved." "\
|
|
153
|
1297 something in this group has been set and saved.")
|
|
|
1298 (rogue "@" custom-rogue-face "\
|
|
155
|
1299 this %c has not been changed with customize." "\
|
|
153
|
1300 something in this group is not prepared for customization.")
|
|
|
1301 (standard " " nil "\
|
|
155
|
1302 this %c is unchanged from its standard setting." "\
|
|
|
1303 visible group members are all at standard settings."))
|
|
28
|
1304 "Alist of customize option states.
|
|
153
|
1305 Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where
|
|
28
|
1306
|
|
|
1307 STATE is one of the following symbols:
|
|
|
1308
|
|
|
1309 `nil'
|
|
|
1310 For internal use, should never occur.
|
|
|
1311 `unknown'
|
|
|
1312 For internal use, should never occur.
|
|
|
1313 `hidden'
|
|
|
1314 This item is not being displayed.
|
|
|
1315 `invalid'
|
|
|
1316 This item is modified, but has an invalid form.
|
|
|
1317 `modified'
|
|
|
1318 This item is modified, and has a valid form.
|
|
|
1319 `set'
|
|
|
1320 This item has been set but not saved.
|
|
|
1321 `changed'
|
|
|
1322 The current value of this item has been changed temporarily.
|
|
|
1323 `saved'
|
|
|
1324 This item is marked for saving.
|
|
|
1325 `rogue'
|
|
|
1326 This item has no customization information.
|
|
153
|
1327 `standard'
|
|
|
1328 This item is unchanged from the standard setting.
|
|
28
|
1329
|
|
|
1330 MAGIC is a string used to present that state.
|
|
|
1331
|
|
|
1332 FACE is a face used to present the state.
|
|
|
1333
|
|
153
|
1334 ITEM-DESC is a string describing the state for options.
|
|
28
|
1335
|
|
153
|
1336 GROUP-DESC is a string describing the state for groups. If this is
|
|
|
1337 left out, ITEM-DESC will be used.
|
|
|
1338
|
|
155
|
1339 The string %c in either description will be replaced with the
|
|
|
1340 category of the item. These are `group'. `option', and `face'.
|
|
|
1341
|
|
153
|
1342 The list should be sorted most significant first.")
|
|
28
|
1343
|
|
|
1344 (defcustom custom-magic-show 'long
|
|
155
|
1345 "If non-nil, show textual description of the state.
|
|
165
|
1346 If `long', show a full-line description, not just one word."
|
|
28
|
1347 :type '(choice (const :tag "no" nil)
|
|
|
1348 (const short)
|
|
|
1349 (const long))
|
|
161
|
1350 :group 'custom-buffer)
|
|
28
|
1351
|
|
155
|
1352 (defcustom custom-magic-show-hidden '(option face)
|
|
165
|
1353 "Control whether the State button is shown for hidden items.
|
|
|
1354 The value should be a list with the custom categories where the State
|
|
155
|
1355 button should be visible. Possible categories are `group', `option',
|
|
|
1356 and `face'."
|
|
|
1357 :type '(set (const group) (const option) (const face))
|
|
161
|
1358 :group 'custom-buffer)
|
|
155
|
1359
|
|
153
|
1360 (defcustom custom-magic-show-button nil
|
|
165
|
1361 "Show a \"magic\" button indicating the state of each customization option."
|
|
28
|
1362 :type 'boolean
|
|
161
|
1363 :group 'custom-buffer)
|
|
28
|
1364
|
|
|
1365 (define-widget 'custom-magic 'default
|
|
|
1366 "Show and manipulate state for a customization option."
|
|
|
1367 :format "%v"
|
|
149
|
1368 :action 'widget-parent-action
|
|
|
1369 :notify 'ignore
|
|
28
|
1370 :value-get 'ignore
|
|
|
1371 :value-create 'custom-magic-value-create
|
|
|
1372 :value-delete 'widget-children-value-delete)
|
|
|
1373
|
|
149
|
1374 (defun widget-magic-mouse-down-action (widget &optional event)
|
|
|
1375 ;; Non-nil unless hidden.
|
|
|
1376 (not (eq (widget-get (widget-get (widget-get widget :parent) :parent)
|
|
|
1377 :custom-state)
|
|
|
1378 'hidden)))
|
|
|
1379
|
|
28
|
1380 (defun custom-magic-value-create (widget)
|
|
|
1381 ;; Create compact status report for WIDGET.
|
|
|
1382 (let* ((parent (widget-get widget :parent))
|
|
|
1383 (state (widget-get parent :custom-state))
|
|
155
|
1384 (hidden (eq state 'hidden))
|
|
28
|
1385 (entry (assq state custom-magic-alist))
|
|
|
1386 (magic (nth 1 entry))
|
|
|
1387 (face (nth 2 entry))
|
|
155
|
1388 (category (widget-get parent :custom-category))
|
|
|
1389 (text (or (and (eq category 'group)
|
|
153
|
1390 (nth 4 entry))
|
|
|
1391 (nth 3 entry)))
|
|
28
|
1392 (lisp (eq (widget-get parent :custom-form) 'lisp))
|
|
|
1393 children)
|
|
155
|
1394 (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text)
|
|
|
1395 (setq text (concat (match-string 1 text)
|
|
|
1396 (symbol-name category)
|
|
|
1397 (match-string 2 text))))
|
|
|
1398 (when (and custom-magic-show
|
|
|
1399 (or (not hidden)
|
|
|
1400 (memq category custom-magic-show-hidden)))
|
|
|
1401 (insert " ")
|
|
165
|
1402 (when (and (eq category 'group)
|
|
|
1403 (not (and (eq custom-buffer-style 'links)
|
|
|
1404 (> (widget-get parent :custom-level) 1))))
|
|
163
|
1405 (insert-char ?\ (* custom-buffer-indent
|
|
|
1406 (widget-get parent :custom-level))))
|
|
149
|
1407 (push (widget-create-child-and-convert
|
|
|
1408 widget 'choice-item
|
|
155
|
1409 :help-echo "Change the state of this item."
|
|
|
1410 :format (if hidden "%t" "%[%t%]")
|
|
|
1411 :button-prefix 'widget-push-button-prefix
|
|
|
1412 :button-suffix 'widget-push-button-suffix
|
|
149
|
1413 :mouse-down-action 'widget-magic-mouse-down-action
|
|
|
1414 :tag "State")
|
|
28
|
1415 children)
|
|
|
1416 (insert ": ")
|
|
165
|
1417 (let ((start (point)))
|
|
|
1418 (if (eq custom-magic-show 'long)
|
|
|
1419 (insert text)
|
|
|
1420 (insert (symbol-name state)))
|
|
|
1421 (when lisp
|
|
|
1422 (insert " (lisp)"))
|
|
|
1423 (put-text-property start (point) 'face 'custom-state-face))
|
|
28
|
1424 (insert "\n"))
|
|
165
|
1425 (when (and (eq category 'group)
|
|
|
1426 (not (and (eq custom-buffer-style 'links)
|
|
|
1427 (> (widget-get parent :custom-level) 1))))
|
|
163
|
1428 (insert-char ?\ (* custom-buffer-indent
|
|
|
1429 (widget-get parent :custom-level))))
|
|
28
|
1430 (when custom-magic-show-button
|
|
|
1431 (when custom-magic-show
|
|
|
1432 (let ((indent (widget-get parent :indent)))
|
|
|
1433 (when indent
|
|
|
1434 (insert-char ? indent))))
|
|
149
|
1435 (push (widget-create-child-and-convert
|
|
|
1436 widget 'choice-item
|
|
|
1437 :mouse-down-action 'widget-magic-mouse-down-action
|
|
|
1438 :button-face face
|
|
155
|
1439 :button-prefix ""
|
|
|
1440 :button-suffix ""
|
|
149
|
1441 :help-echo "Change the state."
|
|
155
|
1442 :format (if hidden "%t" "%[%t%]")
|
|
149
|
1443 :tag (if lisp
|
|
|
1444 (concat "(" magic ")")
|
|
|
1445 (concat "[" magic "]")))
|
|
28
|
1446 children)
|
|
|
1447 (insert " "))
|
|
|
1448 (widget-put widget :children children)))
|
|
|
1449
|
|
|
1450 (defun custom-magic-reset (widget)
|
|
|
1451 "Redraw the :custom-magic property of WIDGET."
|
|
|
1452 (let ((magic (widget-get widget :custom-magic)))
|
|
|
1453 (widget-value-set magic (widget-value magic))))
|
|
|
1454
|
|
|
1455 ;;; The `custom' Widget.
|
|
|
1456
|
|
165
|
1457 (defface custom-button-face nil
|
|
|
1458 "Face used for buttons in customization buffers."
|
|
|
1459 :group 'custom-faces)
|
|
|
1460
|
|
|
1461 (defface custom-documentation-face nil
|
|
|
1462 "Face used for documentation strings in customization buffers."
|
|
|
1463 :group 'custom-faces)
|
|
|
1464
|
|
|
1465 (defface custom-state-face '((((class color)
|
|
|
1466 (background dark))
|
|
|
1467 (:foreground "lime green"))
|
|
|
1468 (((class color)
|
|
|
1469 (background light))
|
|
|
1470 (:foreground "dark green"))
|
|
|
1471 (t nil))
|
|
|
1472 "Face used for State descriptions in the customize buffer."
|
|
|
1473 :group 'custom-faces)
|
|
|
1474
|
|
28
|
1475 (define-widget 'custom 'default
|
|
|
1476 "Customize a user option."
|
|
163
|
1477 :format "%v"
|
|
28
|
1478 :convert-widget 'custom-convert-widget
|
|
|
1479 :notify 'custom-notify
|
|
163
|
1480 :custom-prefix ""
|
|
28
|
1481 :custom-level 1
|
|
|
1482 :custom-state 'hidden
|
|
|
1483 :documentation-property 'widget-subclass-responsibility
|
|
|
1484 :value-create 'widget-subclass-responsibility
|
|
|
1485 :value-delete 'widget-children-value-delete
|
|
149
|
1486 :value-get 'widget-value-value-get
|
|
|
1487 :validate 'widget-children-validate
|
|
165
|
1488 :button-face 'custom-button-face
|
|
28
|
1489 :match (lambda (widget value) (symbolp value)))
|
|
|
1490
|
|
|
1491 (defun custom-convert-widget (widget)
|
|
|
1492 ;; Initialize :value and :tag from :args in WIDGET.
|
|
|
1493 (let ((args (widget-get widget :args)))
|
|
|
1494 (when args
|
|
|
1495 (widget-put widget :value (widget-apply widget
|
|
|
1496 :value-to-internal (car args)))
|
|
|
1497 (widget-put widget :tag (custom-unlispify-tag-name (car args)))
|
|
|
1498 (widget-put widget :args nil)))
|
|
|
1499 widget)
|
|
|
1500
|
|
|
1501 (defun custom-notify (widget &rest args)
|
|
|
1502 "Keep track of changes."
|
|
155
|
1503 (let ((state (widget-get widget :custom-state)))
|
|
|
1504 (unless (eq state 'modified)
|
|
|
1505 (unless (memq state '(nil unknown hidden))
|
|
|
1506 (widget-put widget :custom-state 'modified))
|
|
|
1507 (custom-magic-reset widget)
|
|
|
1508 (apply 'widget-default-notify widget args))))
|
|
28
|
1509
|
|
|
1510 (defun custom-redraw (widget)
|
|
|
1511 "Redraw WIDGET with current settings."
|
|
149
|
1512 (let ((line (count-lines (point-min) (point)))
|
|
|
1513 (column (current-column))
|
|
|
1514 (pos (point))
|
|
28
|
1515 (from (marker-position (widget-get widget :from)))
|
|
|
1516 (to (marker-position (widget-get widget :to))))
|
|
|
1517 (save-excursion
|
|
|
1518 (widget-value-set widget (widget-value widget))
|
|
|
1519 (custom-redraw-magic widget))
|
|
|
1520 (when (and (>= pos from) (<= pos to))
|
|
149
|
1521 (condition-case nil
|
|
|
1522 (progn
|
|
|
1523 (if (> column 0)
|
|
|
1524 (goto-line line)
|
|
|
1525 (goto-line (1+ line)))
|
|
|
1526 (move-to-column column))
|
|
|
1527 (error nil)))))
|
|
28
|
1528
|
|
|
1529 (defun custom-redraw-magic (widget)
|
|
|
1530 "Redraw WIDGET state with current settings."
|
|
|
1531 (while widget
|
|
|
1532 (let ((magic (widget-get widget :custom-magic)))
|
|
163
|
1533 (cond (magic
|
|
|
1534 (widget-value-set magic (widget-value magic))
|
|
|
1535 (when (setq widget (widget-get widget :group))
|
|
|
1536 (custom-group-state-update widget)))
|
|
|
1537 (t
|
|
|
1538 (setq widget nil)))))
|
|
28
|
1539 (widget-setup))
|
|
|
1540
|
|
|
1541 (defun custom-show (widget value)
|
|
|
1542 "Non-nil if WIDGET should be shown with VALUE by default."
|
|
|
1543 (let ((show (widget-get widget :custom-show)))
|
|
|
1544 (cond ((null show)
|
|
|
1545 nil)
|
|
|
1546 ((eq t show)
|
|
|
1547 t)
|
|
|
1548 (t
|
|
|
1549 (funcall show widget value)))))
|
|
|
1550
|
|
124
|
1551 (defvar custom-load-recursion nil
|
|
|
1552 "Hack to avoid recursive dependencies.")
|
|
|
1553
|
|
28
|
1554 (defun custom-load-symbol (symbol)
|
|
|
1555 "Load all dependencies for SYMBOL."
|
|
124
|
1556 (unless custom-load-recursion
|
|
|
1557 (let ((custom-load-recursion t)
|
|
|
1558 (loads (get symbol 'custom-loads))
|
|
|
1559 load)
|
|
|
1560 (while loads
|
|
|
1561 (setq load (car loads)
|
|
|
1562 loads (cdr loads))
|
|
|
1563 (cond ((symbolp load)
|
|
|
1564 (condition-case nil
|
|
|
1565 (require load)
|
|
|
1566 (error nil)))
|
|
155
|
1567 ;; Don't reload a file already loaded.
|
|
124
|
1568 ((assoc load load-history))
|
|
155
|
1569 ((assoc (locate-library load) load-history))
|
|
124
|
1570 (t
|
|
|
1571 (condition-case nil
|
|
155
|
1572 ;; Without this, we would load cus-edit recursively.
|
|
|
1573 ;; We are still loading it when we call this,
|
|
|
1574 ;; and it is not in load-history yet.
|
|
|
1575 (or (equal load "cus-edit")
|
|
|
1576 (load-library load))
|
|
124
|
1577 (error nil))))))))
|
|
28
|
1578
|
|
|
1579 (defun custom-load-widget (widget)
|
|
|
1580 "Load all dependencies for WIDGET."
|
|
|
1581 (custom-load-symbol (widget-value widget)))
|
|
|
1582
|
|
167
|
1583 (defun custom-unloaded-symbol-p (symbol)
|
|
|
1584 "Return non-nil if the dependencies of SYMBOL has not yet been loaded."
|
|
|
1585 (let ((found nil)
|
|
|
1586 (loads (get symbol 'custom-loads))
|
|
|
1587 load)
|
|
|
1588 (while loads
|
|
|
1589 (setq load (car loads)
|
|
|
1590 loads (cdr loads))
|
|
|
1591 (cond ((symbolp load)
|
|
|
1592 (unless (featurep load)
|
|
|
1593 (setq found t)))
|
|
|
1594 ((assoc load load-history))
|
|
|
1595 ((assoc (locate-library load) load-history)
|
|
|
1596 (message nil))
|
|
|
1597 (t
|
|
|
1598 (setq found t))))
|
|
|
1599 found))
|
|
|
1600
|
|
|
1601 (defun custom-unloaded-widget-p (widget)
|
|
|
1602 "Return non-nil if the dependencies of WIDGET has not yet been loaded."
|
|
|
1603 (custom-unloaded-symbol-p (widget-value widget)))
|
|
|
1604
|
|
149
|
1605 (defun custom-toggle-hide (widget)
|
|
|
1606 "Toggle visibility of WIDGET."
|
|
167
|
1607 (custom-load-widget widget)
|
|
149
|
1608 (let ((state (widget-get widget :custom-state)))
|
|
|
1609 (cond ((memq state '(invalid modified))
|
|
|
1610 (error "There are unset changes"))
|
|
|
1611 ((eq state 'hidden)
|
|
|
1612 (widget-put widget :custom-state 'unknown))
|
|
|
1613 (t
|
|
155
|
1614 (widget-put widget :documentation-shown nil)
|
|
149
|
1615 (widget-put widget :custom-state 'hidden)))
|
|
163
|
1616 (custom-redraw widget)
|
|
|
1617 (widget-setup)))
|
|
149
|
1618
|
|
155
|
1619 (defun custom-toggle-parent (widget &rest ignore)
|
|
165
|
1620 "Toggle visibility of parent of WIDGET."
|
|
155
|
1621 (custom-toggle-hide (widget-get widget :parent)))
|
|
|
1622
|
|
163
|
1623 (defun custom-add-see-also (widget &optional prefix)
|
|
|
1624 "Add `See also ...' to WIDGET if there are any links.
|
|
|
1625 Insert PREFIX first if non-nil."
|
|
|
1626 (let* ((symbol (widget-get widget :value))
|
|
|
1627 (links (get symbol 'custom-links))
|
|
|
1628 (many (> (length links) 2))
|
|
|
1629 (buttons (widget-get widget :buttons))
|
|
|
1630 (indent (widget-get widget :indent)))
|
|
|
1631 (when links
|
|
|
1632 (when indent
|
|
|
1633 (insert-char ?\ indent))
|
|
|
1634 (when prefix
|
|
|
1635 (insert prefix))
|
|
|
1636 (insert "See also ")
|
|
|
1637 (while links
|
|
|
1638 (push (widget-create-child-and-convert widget (car links))
|
|
|
1639 buttons)
|
|
|
1640 (setq links (cdr links))
|
|
|
1641 (cond ((null links)
|
|
|
1642 (insert ".\n"))
|
|
|
1643 ((null (cdr links))
|
|
|
1644 (if many
|
|
|
1645 (insert ", and ")
|
|
|
1646 (insert " and ")))
|
|
|
1647 (t
|
|
|
1648 (insert ", "))))
|
|
|
1649 (widget-put widget :buttons buttons))))
|
|
|
1650
|
|
165
|
1651 (defun custom-add-parent-links (widget &optional initial-string)
|
|
|
1652 "Add \"Parent groups: ...\" to WIDGET if the group has parents.
|
|
|
1653 The value if non-nil if any parents were found.
|
|
|
1654 If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
|
|
163
|
1655 (let ((name (widget-value widget))
|
|
|
1656 (type (widget-type widget))
|
|
|
1657 (buttons (widget-get widget :buttons))
|
|
165
|
1658 (start (point))
|
|
163
|
1659 found)
|
|
165
|
1660 (insert (or initial-string "Parent groups:"))
|
|
163
|
1661 (mapatoms (lambda (symbol)
|
|
167
|
1662 (let ((entry (assq name
|
|
|
1663 (condition-case nil
|
|
|
1664 (get symbol 'custom-group)
|
|
|
1665 (t (progn
|
|
|
1666 (message "Bad plist in %s"
|
|
|
1667 (symbol-name symbol))
|
|
|
1668 nil))))))
|
|
165
|
1669 (when (eq (nth 1 entry) type)
|
|
|
1670 (insert " ")
|
|
|
1671 (push (widget-create-child-and-convert
|
|
|
1672 widget 'custom-group-link
|
|
|
1673 :tag (custom-unlispify-tag-name symbol)
|
|
|
1674 symbol)
|
|
|
1675 buttons)
|
|
|
1676 (setq found t)))))
|
|
163
|
1677 (widget-put widget :buttons buttons)
|
|
165
|
1678 (if found
|
|
|
1679 (insert "\n")
|
|
|
1680 (delete-region start (point)))
|
|
|
1681 found))
|
|
163
|
1682
|
|
28
|
1683 ;;; The `custom-variable' Widget.
|
|
|
1684
|
|
165
|
1685 (defface custom-variable-tag-face '((((class color)
|
|
|
1686 (background dark))
|
|
|
1687 (:foreground "light blue" :underline t))
|
|
|
1688 (((class color)
|
|
|
1689 (background light))
|
|
|
1690 (:foreground "blue" :underline t))
|
|
|
1691 (t (:underline t)))
|
|
28
|
1692 "Face used for unpushable variable tags."
|
|
124
|
1693 :group 'custom-faces)
|
|
28
|
1694
|
|
|
1695 (defface custom-variable-button-face '((t (:underline t :bold t)))
|
|
|
1696 "Face used for pushable variable tags."
|
|
124
|
1697 :group 'custom-faces)
|
|
28
|
1698
|
|
|
1699 (define-widget 'custom-variable 'custom
|
|
|
1700 "Customize variable."
|
|
163
|
1701 :format "%v"
|
|
30
|
1702 :help-echo "Set or reset this variable."
|
|
28
|
1703 :documentation-property 'variable-documentation
|
|
155
|
1704 :custom-category 'option
|
|
28
|
1705 :custom-state nil
|
|
|
1706 :custom-menu 'custom-variable-menu-create
|
|
|
1707 :custom-form 'edit
|
|
|
1708 :value-create 'custom-variable-value-create
|
|
|
1709 :action 'custom-variable-action
|
|
|
1710 :custom-set 'custom-variable-set
|
|
|
1711 :custom-save 'custom-variable-save
|
|
|
1712 :custom-reset-current 'custom-redraw
|
|
|
1713 :custom-reset-saved 'custom-variable-reset-saved
|
|
153
|
1714 :custom-reset-standard 'custom-variable-reset-standard)
|
|
28
|
1715
|
|
120
|
1716 (defun custom-variable-type (symbol)
|
|
|
1717 "Return a widget suitable for editing the value of SYMBOL.
|
|
|
1718 If SYMBOL has a `custom-type' property, use that.
|
|
|
1719 Otherwise, look up symbol in `custom-guess-type-alist'."
|
|
|
1720 (let* ((type (or (get symbol 'custom-type)
|
|
153
|
1721 (and (not (get symbol 'standard-value))
|
|
124
|
1722 (custom-guess-type symbol))
|
|
120
|
1723 'sexp))
|
|
|
1724 (options (get symbol 'custom-options))
|
|
|
1725 (tmp (if (listp type)
|
|
149
|
1726 (copy-sequence type)
|
|
120
|
1727 (list type))))
|
|
|
1728 (when options
|
|
|
1729 (widget-put tmp :options options))
|
|
|
1730 tmp))
|
|
|
1731
|
|
28
|
1732 (defun custom-variable-value-create (widget)
|
|
|
1733 "Here is where you edit the variables value."
|
|
|
1734 (custom-load-widget widget)
|
|
|
1735 (let* ((buttons (widget-get widget :buttons))
|
|
|
1736 (children (widget-get widget :children))
|
|
|
1737 (form (widget-get widget :custom-form))
|
|
|
1738 (state (widget-get widget :custom-state))
|
|
|
1739 (symbol (widget-get widget :value))
|
|
|
1740 (tag (widget-get widget :tag))
|
|
120
|
1741 (type (custom-variable-type symbol))
|
|
28
|
1742 (conv (widget-convert type))
|
|
149
|
1743 (get (or (get symbol 'custom-get) 'default-value))
|
|
163
|
1744 (prefix (widget-get widget :custom-prefix))
|
|
|
1745 (last (widget-get widget :custom-last))
|
|
28
|
1746 (value (if (default-boundp symbol)
|
|
149
|
1747 (funcall get symbol)
|
|
28
|
1748 (widget-get conv :value))))
|
|
|
1749 ;; If the widget is new, the child determine whether it is hidden.
|
|
|
1750 (cond (state)
|
|
|
1751 ((custom-show type value)
|
|
|
1752 (setq state 'unknown))
|
|
|
1753 (t
|
|
|
1754 (setq state 'hidden)))
|
|
|
1755 ;; If we don't know the state, see if we need to edit it in lisp form.
|
|
|
1756 (when (eq state 'unknown)
|
|
|
1757 (unless (widget-apply conv :match value)
|
|
|
1758 ;; (widget-apply (widget-convert type) :match value)
|
|
|
1759 (setq form 'lisp)))
|
|
|
1760 ;; Now we can create the child widget.
|
|
163
|
1761 (cond ((eq custom-buffer-style 'tree)
|
|
|
1762 (insert prefix (if last " `--- " " |--- "))
|
|
|
1763 (push (widget-create-child-and-convert
|
|
167
|
1764 widget 'custom-browse-variable-tag)
|
|
163
|
1765 buttons)
|
|
|
1766 (insert " " tag "\n")
|
|
|
1767 (widget-put widget :buttons buttons))
|
|
|
1768 ((eq state 'hidden)
|
|
28
|
1769 ;; Indicate hidden value.
|
|
|
1770 (push (widget-create-child-and-convert
|
|
|
1771 widget 'item
|
|
155
|
1772 :format "%{%t%}: "
|
|
165
|
1773 :sample-face 'custom-variable-tag-face
|
|
28
|
1774 :tag tag
|
|
|
1775 :parent widget)
|
|
155
|
1776 buttons)
|
|
|
1777 (push (widget-create-child-and-convert
|
|
|
1778 widget 'visibility
|
|
163
|
1779 :help-echo "Show the value of this option."
|
|
155
|
1780 :action 'custom-toggle-parent
|
|
|
1781 nil)
|
|
|
1782 buttons))
|
|
28
|
1783 ((eq form 'lisp)
|
|
|
1784 ;; In lisp mode edit the saved value when possible.
|
|
|
1785 (let* ((value (cond ((get symbol 'saved-value)
|
|
|
1786 (car (get symbol 'saved-value)))
|
|
153
|
1787 ((get symbol 'standard-value)
|
|
|
1788 (car (get symbol 'standard-value)))
|
|
28
|
1789 ((default-boundp symbol)
|
|
149
|
1790 (custom-quote (funcall get symbol)))
|
|
28
|
1791 (t
|
|
|
1792 (custom-quote (widget-get conv :value))))))
|
|
155
|
1793 (insert (symbol-name symbol) ": ")
|
|
|
1794 (push (widget-create-child-and-convert
|
|
163
|
1795 widget 'visibility
|
|
|
1796 :help-echo "Hide the value of this option."
|
|
|
1797 :action 'custom-toggle-parent
|
|
|
1798 t)
|
|
|
1799 buttons)
|
|
155
|
1800 (insert " ")
|
|
28
|
1801 (push (widget-create-child-and-convert
|
|
|
1802 widget 'sexp
|
|
|
1803 :button-face 'custom-variable-button-face
|
|
155
|
1804 :format "%v"
|
|
28
|
1805 :tag (symbol-name symbol)
|
|
|
1806 :parent widget
|
|
|
1807 :value value)
|
|
|
1808 children)))
|
|
|
1809 (t
|
|
|
1810 ;; Edit mode.
|
|
155
|
1811 (let* ((format (widget-get type :format))
|
|
|
1812 tag-format value-format)
|
|
|
1813 (unless (string-match ":" format)
|
|
|
1814 (error "Bad format."))
|
|
|
1815 (setq tag-format (substring format 0 (match-end 0)))
|
|
|
1816 (setq value-format (substring format (match-end 0)))
|
|
|
1817 (push (widget-create-child-and-convert
|
|
|
1818 widget 'item
|
|
|
1819 :format tag-format
|
|
|
1820 :action 'custom-tag-action
|
|
163
|
1821 :help-echo "Change value of this option."
|
|
155
|
1822 :mouse-down-action 'custom-tag-mouse-down-action
|
|
|
1823 :button-face 'custom-variable-button-face
|
|
165
|
1824 :sample-face 'custom-variable-tag-face
|
|
155
|
1825 tag)
|
|
|
1826 buttons)
|
|
|
1827 (insert " ")
|
|
|
1828 (push (widget-create-child-and-convert
|
|
|
1829 widget 'visibility
|
|
163
|
1830 :help-echo "Hide the value of this option."
|
|
155
|
1831 :action 'custom-toggle-parent
|
|
|
1832 t)
|
|
|
1833 buttons)
|
|
|
1834 (push (widget-create-child-and-convert
|
|
|
1835 widget type
|
|
|
1836 :format value-format
|
|
|
1837 :value value)
|
|
|
1838 children))))
|
|
163
|
1839 (unless (eq custom-buffer-style 'tree)
|
|
|
1840 ;; Now update the state.
|
|
|
1841 (unless (eq (preceding-char) ?\n)
|
|
|
1842 (widget-insert "\n"))
|
|
|
1843 (if (eq state 'hidden)
|
|
|
1844 (widget-put widget :custom-state state)
|
|
|
1845 (custom-variable-state-set widget))
|
|
|
1846 ;; Create the magic button.
|
|
|
1847 (let ((magic (widget-create-child-and-convert
|
|
|
1848 widget 'custom-magic nil)))
|
|
|
1849 (widget-put widget :custom-magic magic)
|
|
|
1850 (push magic buttons))
|
|
|
1851 ;; Update properties.
|
|
|
1852 (widget-put widget :custom-form form)
|
|
|
1853 (widget-put widget :buttons buttons)
|
|
|
1854 (widget-put widget :children children)
|
|
|
1855 ;; Insert documentation.
|
|
|
1856 (widget-default-format-handler widget ?h)
|
|
|
1857 ;; See also.
|
|
|
1858 (unless (eq state 'hidden)
|
|
|
1859 (when (eq (widget-get widget :custom-level) 1)
|
|
|
1860 (custom-add-parent-links widget))
|
|
|
1861 (custom-add-see-also widget)))))
|
|
28
|
1862
|
|
155
|
1863 (defun custom-tag-action (widget &rest args)
|
|
|
1864 "Pass :action to first child of WIDGET's parent."
|
|
|
1865 (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
|
|
|
1866 :action args))
|
|
|
1867
|
|
|
1868 (defun custom-tag-mouse-down-action (widget &rest args)
|
|
|
1869 "Pass :mouse-down-action to first child of WIDGET's parent."
|
|
|
1870 (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
|
|
|
1871 :mouse-down-action args))
|
|
|
1872
|
|
28
|
1873 (defun custom-variable-state-set (widget)
|
|
|
1874 "Set the state of WIDGET."
|
|
|
1875 (let* ((symbol (widget-value widget))
|
|
149
|
1876 (get (or (get symbol 'custom-get) 'default-value))
|
|
28
|
1877 (value (if (default-boundp symbol)
|
|
149
|
1878 (funcall get symbol)
|
|
28
|
1879 (widget-get widget :value)))
|
|
|
1880 tmp
|
|
|
1881 (state (cond ((setq tmp (get symbol 'customized-value))
|
|
|
1882 (if (condition-case nil
|
|
|
1883 (equal value (eval (car tmp)))
|
|
|
1884 (error nil))
|
|
|
1885 'set
|
|
|
1886 'changed))
|
|
|
1887 ((setq tmp (get symbol 'saved-value))
|
|
|
1888 (if (condition-case nil
|
|
|
1889 (equal value (eval (car tmp)))
|
|
|
1890 (error nil))
|
|
|
1891 'saved
|
|
|
1892 'changed))
|
|
153
|
1893 ((setq tmp (get symbol 'standard-value))
|
|
28
|
1894 (if (condition-case nil
|
|
|
1895 (equal value (eval (car tmp)))
|
|
|
1896 (error nil))
|
|
153
|
1897 'standard
|
|
28
|
1898 'changed))
|
|
|
1899 (t 'rogue))))
|
|
|
1900 (widget-put widget :custom-state state)))
|
|
|
1901
|
|
|
1902 (defvar custom-variable-menu
|
|
163
|
1903 '(("Set" custom-variable-set
|
|
149
|
1904 (lambda (widget)
|
|
|
1905 (eq (widget-get widget :custom-state) 'modified)))
|
|
|
1906 ("Save" custom-variable-save
|
|
|
1907 (lambda (widget)
|
|
|
1908 (memq (widget-get widget :custom-state) '(modified set changed rogue))))
|
|
|
1909 ("Reset to Current" custom-redraw
|
|
|
1910 (lambda (widget)
|
|
|
1911 (and (default-boundp (widget-value widget))
|
|
|
1912 (memq (widget-get widget :custom-state) '(modified changed)))))
|
|
|
1913 ("Reset to Saved" custom-variable-reset-saved
|
|
|
1914 (lambda (widget)
|
|
|
1915 (and (get (widget-value widget) 'saved-value)
|
|
|
1916 (memq (widget-get widget :custom-state)
|
|
|
1917 '(modified set changed rogue)))))
|
|
153
|
1918 ("Reset to Standard Settings" custom-variable-reset-standard
|
|
149
|
1919 (lambda (widget)
|
|
153
|
1920 (and (get (widget-value widget) 'standard-value)
|
|
149
|
1921 (memq (widget-get widget :custom-state)
|
|
163
|
1922 '(modified set changed saved rogue)))))
|
|
|
1923 ("---" ignore ignore)
|
|
|
1924 ("Don't show as Lisp expression" custom-variable-edit
|
|
|
1925 (lambda (widget)
|
|
|
1926 (not (eq (widget-get widget :custom-form) 'edit))))
|
|
|
1927 ("Show as Lisp expression" custom-variable-edit-lisp
|
|
|
1928 (lambda (widget)
|
|
|
1929 (not (eq (widget-get widget :custom-form) 'lisp)))))
|
|
28
|
1930 "Alist of actions for the `custom-variable' widget.
|
|
149
|
1931 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
|
|
|
1932 the menu entry, ACTION is the function to call on the widget when the
|
|
|
1933 menu is selected, and FILTER is a predicate which takes a `custom-variable'
|
|
|
1934 widget as an argument, and returns non-nil if ACTION is valid on that
|
|
|
1935 widget. If FILTER is nil, ACTION is always valid.")
|
|
28
|
1936
|
|
|
1937 (defun custom-variable-action (widget &optional event)
|
|
|
1938 "Show the menu for `custom-variable' WIDGET.
|
|
|
1939 Optional EVENT is the location for the menu."
|
|
|
1940 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
149
|
1941 (custom-toggle-hide widget)
|
|
|
1942 (unless (eq (widget-get widget :custom-state) 'modified)
|
|
|
1943 (custom-variable-state-set widget))
|
|
|
1944 (custom-redraw-magic widget)
|
|
28
|
1945 (let* ((completion-ignore-case t)
|
|
155
|
1946 (answer (widget-choose (concat "Operation on "
|
|
|
1947 (custom-unlispify-tag-name
|
|
|
1948 (widget-get widget :value)))
|
|
149
|
1949 (custom-menu-filter custom-variable-menu
|
|
|
1950 widget)
|
|
28
|
1951 event)))
|
|
|
1952 (if answer
|
|
|
1953 (funcall answer widget)))))
|
|
|
1954
|
|
|
1955 (defun custom-variable-edit (widget)
|
|
|
1956 "Edit value of WIDGET."
|
|
|
1957 (widget-put widget :custom-state 'unknown)
|
|
|
1958 (widget-put widget :custom-form 'edit)
|
|
|
1959 (custom-redraw widget))
|
|
|
1960
|
|
|
1961 (defun custom-variable-edit-lisp (widget)
|
|
|
1962 "Edit the lisp representation of the value of WIDGET."
|
|
|
1963 (widget-put widget :custom-state 'unknown)
|
|
|
1964 (widget-put widget :custom-form 'lisp)
|
|
|
1965 (custom-redraw widget))
|
|
|
1966
|
|
|
1967 (defun custom-variable-set (widget)
|
|
|
1968 "Set the current value for the variable being edited by WIDGET."
|
|
149
|
1969 (let* ((form (widget-get widget :custom-form))
|
|
|
1970 (state (widget-get widget :custom-state))
|
|
|
1971 (child (car (widget-get widget :children)))
|
|
|
1972 (symbol (widget-value widget))
|
|
|
1973 (set (or (get symbol 'custom-set) 'set-default))
|
|
|
1974 val)
|
|
28
|
1975 (cond ((eq state 'hidden)
|
|
|
1976 (error "Cannot set hidden variable."))
|
|
|
1977 ((setq val (widget-apply child :validate))
|
|
|
1978 (goto-char (widget-get val :from))
|
|
|
1979 (error "%s" (widget-get val :error)))
|
|
|
1980 ((eq form 'lisp)
|
|
149
|
1981 (funcall set symbol (eval (setq val (widget-value child))))
|
|
28
|
1982 (put symbol 'customized-value (list val)))
|
|
|
1983 (t
|
|
149
|
1984 (funcall set symbol (setq val (widget-value child)))
|
|
28
|
1985 (put symbol 'customized-value (list (custom-quote val)))))
|
|
|
1986 (custom-variable-state-set widget)
|
|
|
1987 (custom-redraw-magic widget)))
|
|
|
1988
|
|
|
1989 (defun custom-variable-save (widget)
|
|
|
1990 "Set the default value for the variable being edited by WIDGET."
|
|
149
|
1991 (let* ((form (widget-get widget :custom-form))
|
|
|
1992 (state (widget-get widget :custom-state))
|
|
|
1993 (child (car (widget-get widget :children)))
|
|
|
1994 (symbol (widget-value widget))
|
|
|
1995 (set (or (get symbol 'custom-set) 'set-default))
|
|
|
1996 val)
|
|
28
|
1997 (cond ((eq state 'hidden)
|
|
|
1998 (error "Cannot set hidden variable."))
|
|
|
1999 ((setq val (widget-apply child :validate))
|
|
|
2000 (goto-char (widget-get val :from))
|
|
|
2001 (error "%s" (widget-get val :error)))
|
|
|
2002 ((eq form 'lisp)
|
|
|
2003 (put symbol 'saved-value (list (widget-value child)))
|
|
149
|
2004 (funcall set symbol (eval (widget-value child))))
|
|
28
|
2005 (t
|
|
|
2006 (put symbol
|
|
|
2007 'saved-value (list (custom-quote (widget-value
|
|
|
2008 child))))
|
|
149
|
2009 (funcall set symbol (widget-value child))))
|
|
28
|
2010 (put symbol 'customized-value nil)
|
|
|
2011 (custom-save-all)
|
|
|
2012 (custom-variable-state-set widget)
|
|
|
2013 (custom-redraw-magic widget)))
|
|
|
2014
|
|
|
2015 (defun custom-variable-reset-saved (widget)
|
|
|
2016 "Restore the saved value for the variable being edited by WIDGET."
|
|
149
|
2017 (let* ((symbol (widget-value widget))
|
|
|
2018 (set (or (get symbol 'custom-set) 'set-default)))
|
|
28
|
2019 (if (get symbol 'saved-value)
|
|
|
2020 (condition-case nil
|
|
149
|
2021 (funcall set symbol (eval (car (get symbol 'saved-value))))
|
|
28
|
2022 (error nil))
|
|
|
2023 (error "No saved value for %s" symbol))
|
|
|
2024 (put symbol 'customized-value nil)
|
|
|
2025 (widget-put widget :custom-state 'unknown)
|
|
|
2026 (custom-redraw widget)))
|
|
|
2027
|
|
153
|
2028 (defun custom-variable-reset-standard (widget)
|
|
|
2029 "Restore the standard setting for the variable being edited by WIDGET."
|
|
149
|
2030 (let* ((symbol (widget-value widget))
|
|
|
2031 (set (or (get symbol 'custom-set) 'set-default)))
|
|
153
|
2032 (if (get symbol 'standard-value)
|
|
|
2033 (funcall set symbol (eval (car (get symbol 'standard-value))))
|
|
|
2034 (error "No standard setting known for %S" symbol))
|
|
28
|
2035 (put symbol 'customized-value nil)
|
|
|
2036 (when (get symbol 'saved-value)
|
|
|
2037 (put symbol 'saved-value nil)
|
|
|
2038 (custom-save-all))
|
|
|
2039 (widget-put widget :custom-state 'unknown)
|
|
|
2040 (custom-redraw widget)))
|
|
|
2041
|
|
|
2042 ;;; The `custom-face-edit' Widget.
|
|
|
2043
|
|
|
2044 (define-widget 'custom-face-edit 'checklist
|
|
|
2045 "Edit face attributes."
|
|
|
2046 :format "%t: %v"
|
|
|
2047 :tag "Attributes"
|
|
|
2048 :extra-offset 12
|
|
30
|
2049 :button-args '(:help-echo "Control whether this attribute have any effect.")
|
|
28
|
2050 :args (mapcar (lambda (att)
|
|
|
2051 (list 'group
|
|
|
2052 :inline t
|
|
30
|
2053 :sibling-args (widget-get (nth 1 att) :sibling-args)
|
|
28
|
2054 (list 'const :format "" :value (nth 0 att))
|
|
|
2055 (nth 1 att)))
|
|
|
2056 custom-face-attributes))
|
|
|
2057
|
|
|
2058 ;;; The `custom-display' Widget.
|
|
|
2059
|
|
|
2060 (define-widget 'custom-display 'menu-choice
|
|
|
2061 "Select a display type."
|
|
|
2062 :tag "Display"
|
|
|
2063 :value t
|
|
30
|
2064 :help-echo "Specify frames where the face attributes should be used."
|
|
28
|
2065 :args '((const :tag "all" t)
|
|
30
|
2066 (checklist
|
|
|
2067 :offset 0
|
|
|
2068 :extra-offset 9
|
|
|
2069 :args ((group :sibling-args (:help-echo "\
|
|
|
2070 Only match the specified window systems.")
|
|
|
2071 (const :format "Type: "
|
|
|
2072 type)
|
|
|
2073 (checklist :inline t
|
|
|
2074 :offset 0
|
|
|
2075 (const :format "X "
|
|
|
2076 :sibling-args (:help-echo "\
|
|
|
2077 The X11 Window System.")
|
|
|
2078 x)
|
|
|
2079 (const :format "PM "
|
|
|
2080 :sibling-args (:help-echo "\
|
|
|
2081 OS/2 Presentation Manager.")
|
|
|
2082 pm)
|
|
|
2083 (const :format "Win32 "
|
|
|
2084 :sibling-args (:help-echo "\
|
|
|
2085 Windows NT/95/97.")
|
|
|
2086 win32)
|
|
|
2087 (const :format "DOS "
|
|
|
2088 :sibling-args (:help-echo "\
|
|
|
2089 Plain MS-DOS.")
|
|
|
2090 pc)
|
|
|
2091 (const :format "TTY%n"
|
|
|
2092 :sibling-args (:help-echo "\
|
|
|
2093 Plain text terminals.")
|
|
|
2094 tty)))
|
|
|
2095 (group :sibling-args (:help-echo "\
|
|
|
2096 Only match the frames with the specified color support.")
|
|
|
2097 (const :format "Class: "
|
|
|
2098 class)
|
|
|
2099 (checklist :inline t
|
|
|
2100 :offset 0
|
|
|
2101 (const :format "Color "
|
|
|
2102 :sibling-args (:help-echo "\
|
|
|
2103 Match color frames.")
|
|
|
2104 color)
|
|
|
2105 (const :format "Grayscale "
|
|
|
2106 :sibling-args (:help-echo "\
|
|
|
2107 Match grayscale frames.")
|
|
|
2108 grayscale)
|
|
|
2109 (const :format "Monochrome%n"
|
|
|
2110 :sibling-args (:help-echo "\
|
|
|
2111 Match frames with no color support.")
|
|
|
2112 mono)))
|
|
|
2113 (group :sibling-args (:help-echo "\
|
|
|
2114 Only match frames with the specified intensity.")
|
|
|
2115 (const :format "\
|
|
|
2116 Background brightness: "
|
|
|
2117 background)
|
|
|
2118 (checklist :inline t
|
|
|
2119 :offset 0
|
|
|
2120 (const :format "Light "
|
|
|
2121 :sibling-args (:help-echo "\
|
|
|
2122 Match frames with light backgrounds.")
|
|
|
2123 light)
|
|
|
2124 (const :format "Dark\n"
|
|
|
2125 :sibling-args (:help-echo "\
|
|
|
2126 Match frames with dark backgrounds.")
|
|
|
2127 dark)))))))
|
|
28
|
2128
|
|
|
2129 ;;; The `custom-face' Widget.
|
|
|
2130
|
|
|
2131 (defface custom-face-tag-face '((t (:underline t)))
|
|
|
2132 "Face used for face tags."
|
|
124
|
2133 :group 'custom-faces)
|
|
28
|
2134
|
|
|
2135 (define-widget 'custom-face 'custom
|
|
|
2136 "Customize face."
|
|
|
2137 :sample-face 'custom-face-tag-face
|
|
30
|
2138 :help-echo "Set or reset this face."
|
|
28
|
2139 :documentation-property '(lambda (face)
|
|
30
|
2140 (face-doc-string face))
|
|
28
|
2141 :value-create 'custom-face-value-create
|
|
|
2142 :action 'custom-face-action
|
|
155
|
2143 :custom-category 'face
|
|
120
|
2144 :custom-form 'selected
|
|
28
|
2145 :custom-set 'custom-face-set
|
|
|
2146 :custom-save 'custom-face-save
|
|
|
2147 :custom-reset-current 'custom-redraw
|
|
|
2148 :custom-reset-saved 'custom-face-reset-saved
|
|
153
|
2149 :custom-reset-standard 'custom-face-reset-standard
|
|
28
|
2150 :custom-menu 'custom-face-menu-create)
|
|
|
2151
|
|
120
|
2152 (define-widget 'custom-face-all 'editable-list
|
|
|
2153 "An editable list of display specifications and attributes."
|
|
|
2154 :entry-format "%i %d %v"
|
|
|
2155 :insert-button-args '(:help-echo "Insert new display specification here.")
|
|
|
2156 :append-button-args '(:help-echo "Append new display specification here.")
|
|
|
2157 :delete-button-args '(:help-echo "Delete this display specification.")
|
|
|
2158 :args '((group :format "%v" custom-display custom-face-edit)))
|
|
|
2159
|
|
|
2160 (defconst custom-face-all (widget-convert 'custom-face-all)
|
|
|
2161 "Converted version of the `custom-face-all' widget.")
|
|
|
2162
|
|
|
2163 (define-widget 'custom-display-unselected 'item
|
|
|
2164 "A display specification that doesn't match the selected display."
|
|
|
2165 :match 'custom-display-unselected-match)
|
|
|
2166
|
|
|
2167 (defun custom-display-unselected-match (widget value)
|
|
|
2168 "Non-nil if VALUE is an unselected display specification."
|
|
149
|
2169 (not (face-spec-set-match-display value (selected-frame))))
|
|
120
|
2170
|
|
|
2171 (define-widget 'custom-face-selected 'group
|
|
|
2172 "Edit the attributes of the selected display in a face specification."
|
|
|
2173 :args '((repeat :format ""
|
|
|
2174 :inline t
|
|
|
2175 (group custom-display-unselected sexp))
|
|
|
2176 (group (sexp :format "") custom-face-edit)
|
|
|
2177 (repeat :format ""
|
|
|
2178 :inline t
|
|
|
2179 sexp)))
|
|
|
2180
|
|
|
2181 (defconst custom-face-selected (widget-convert 'custom-face-selected)
|
|
|
2182 "Converted version of the `custom-face-selected' widget.")
|
|
|
2183
|
|
28
|
2184 (defun custom-face-value-create (widget)
|
|
163
|
2185 "Create a list of the display specifications for WIDGET."
|
|
|
2186 (let ((buttons (widget-get widget :buttons))
|
|
|
2187 (symbol (widget-get widget :value))
|
|
|
2188 (tag (widget-get widget :tag))
|
|
|
2189 (state (widget-get widget :custom-state))
|
|
|
2190 (begin (point))
|
|
|
2191 (is-last (widget-get widget :custom-last))
|
|
|
2192 (prefix (widget-get widget :custom-prefix)))
|
|
|
2193 (unless tag
|
|
|
2194 (setq tag (prin1-to-string symbol)))
|
|
|
2195 (cond ((eq custom-buffer-style 'tree)
|
|
|
2196 (insert prefix (if is-last " `--- " " |--- "))
|
|
|
2197 (push (widget-create-child-and-convert
|
|
167
|
2198 widget 'custom-browse-face-tag)
|
|
163
|
2199 buttons)
|
|
|
2200 (insert " " tag "\n")
|
|
|
2201 (widget-put widget :buttons buttons))
|
|
|
2202 (t
|
|
|
2203 ;; Create tag.
|
|
|
2204 (insert tag)
|
|
|
2205 (if (eq custom-buffer-style 'face)
|
|
|
2206 (insert " ")
|
|
|
2207 (widget-specify-sample widget begin (point))
|
|
|
2208 (insert ": "))
|
|
|
2209 ;; Sample.
|
|
|
2210 (and (string-match "XEmacs" emacs-version)
|
|
|
2211 ;; XEmacs cannot display uninitialized faces.
|
|
|
2212 (not (custom-facep symbol))
|
|
|
2213 (copy-face 'custom-face-empty symbol))
|
|
|
2214 (push (widget-create-child-and-convert widget 'item
|
|
|
2215 :format "(%{%t%})"
|
|
|
2216 :sample-face symbol
|
|
|
2217 :tag "sample")
|
|
|
2218 buttons)
|
|
|
2219 ;; Visibility.
|
|
|
2220 (insert " ")
|
|
|
2221 (push (widget-create-child-and-convert
|
|
|
2222 widget 'visibility
|
|
|
2223 :help-echo "Hide or show this face."
|
|
|
2224 :action 'custom-toggle-parent
|
|
|
2225 (not (eq state 'hidden)))
|
|
|
2226 buttons)
|
|
|
2227 ;; Magic.
|
|
|
2228 (insert "\n")
|
|
|
2229 (let ((magic (widget-create-child-and-convert
|
|
|
2230 widget 'custom-magic nil)))
|
|
|
2231 (widget-put widget :custom-magic magic)
|
|
|
2232 (push magic buttons))
|
|
|
2233 ;; Update buttons.
|
|
|
2234 (widget-put widget :buttons buttons)
|
|
|
2235 ;; Insert documentation.
|
|
|
2236 (widget-default-format-handler widget ?h)
|
|
|
2237 ;; See also.
|
|
|
2238 (unless (eq state 'hidden)
|
|
|
2239 (when (eq (widget-get widget :custom-level) 1)
|
|
|
2240 (custom-add-parent-links widget))
|
|
|
2241 (custom-add-see-also widget))
|
|
|
2242 ;; Editor.
|
|
|
2243 (unless (eq (preceding-char) ?\n)
|
|
|
2244 (insert "\n"))
|
|
|
2245 (unless (eq state 'hidden)
|
|
|
2246 (message "Creating face editor...")
|
|
|
2247 (custom-load-widget widget)
|
|
|
2248 (let* ((symbol (widget-value widget))
|
|
|
2249 (spec (or (get symbol 'saved-face)
|
|
|
2250 (get symbol 'face-defface-spec)
|
|
|
2251 ;; Attempt to construct it.
|
|
|
2252 (list (list t (custom-face-attributes-get
|
|
|
2253 symbol (selected-frame))))))
|
|
|
2254 (form (widget-get widget :custom-form))
|
|
|
2255 (indent (widget-get widget :indent))
|
|
|
2256 (edit (widget-create-child-and-convert
|
|
|
2257 widget
|
|
|
2258 (cond ((and (eq form 'selected)
|
|
|
2259 (widget-apply custom-face-selected
|
|
|
2260 :match spec))
|
|
|
2261 (when indent (insert-char ?\ indent))
|
|
|
2262 'custom-face-selected)
|
|
|
2263 ((and (not (eq form 'lisp))
|
|
|
2264 (widget-apply custom-face-all
|
|
|
2265 :match spec))
|
|
|
2266 'custom-face-all)
|
|
|
2267 (t
|
|
|
2268 (when indent (insert-char ?\ indent))
|
|
|
2269 'sexp))
|
|
|
2270 :value spec)))
|
|
|
2271 (custom-face-state-set widget)
|
|
|
2272 (widget-put widget :children (list edit)))
|
|
|
2273 (message "Creating face editor...done"))))))
|
|
28
|
2274
|
|
|
2275 (defvar custom-face-menu
|
|
163
|
2276 '(("Set" custom-face-set)
|
|
149
|
2277 ("Save" custom-face-save)
|
|
|
2278 ("Reset to Saved" custom-face-reset-saved
|
|
|
2279 (lambda (widget)
|
|
|
2280 (get (widget-value widget) 'saved-face)))
|
|
153
|
2281 ("Reset to Standard Setting" custom-face-reset-standard
|
|
149
|
2282 (lambda (widget)
|
|
163
|
2283 (get (widget-value widget) 'face-defface-spec)))
|
|
|
2284 ("---" ignore ignore)
|
|
|
2285 ("Show all display specs" custom-face-edit-all
|
|
|
2286 (lambda (widget)
|
|
|
2287 (not (eq (widget-get widget :custom-form) 'all))))
|
|
|
2288 ("Just current attributes" custom-face-edit-selected
|
|
|
2289 (lambda (widget)
|
|
|
2290 (not (eq (widget-get widget :custom-form) 'selected))))
|
|
|
2291 ("Show as Lisp expression" custom-face-edit-lisp
|
|
|
2292 (lambda (widget)
|
|
|
2293 (not (eq (widget-get widget :custom-form) 'lisp)))))
|
|
28
|
2294 "Alist of actions for the `custom-face' widget.
|
|
149
|
2295 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
|
|
|
2296 the menu entry, ACTION is the function to call on the widget when the
|
|
|
2297 menu is selected, and FILTER is a predicate which takes a `custom-face'
|
|
|
2298 widget as an argument, and returns non-nil if ACTION is valid on that
|
|
|
2299 widget. If FILTER is nil, ACTION is always valid.")
|
|
28
|
2300
|
|
120
|
2301 (defun custom-face-edit-selected (widget)
|
|
|
2302 "Edit selected attributes of the value of WIDGET."
|
|
|
2303 (widget-put widget :custom-state 'unknown)
|
|
|
2304 (widget-put widget :custom-form 'selected)
|
|
|
2305 (custom-redraw widget))
|
|
|
2306
|
|
|
2307 (defun custom-face-edit-all (widget)
|
|
|
2308 "Edit all attributes of the value of WIDGET."
|
|
|
2309 (widget-put widget :custom-state 'unknown)
|
|
|
2310 (widget-put widget :custom-form 'all)
|
|
|
2311 (custom-redraw widget))
|
|
|
2312
|
|
|
2313 (defun custom-face-edit-lisp (widget)
|
|
|
2314 "Edit the lisp representation of the value of WIDGET."
|
|
|
2315 (widget-put widget :custom-state 'unknown)
|
|
|
2316 (widget-put widget :custom-form 'lisp)
|
|
|
2317 (custom-redraw widget))
|
|
|
2318
|
|
28
|
2319 (defun custom-face-state-set (widget)
|
|
|
2320 "Set the state of WIDGET."
|
|
|
2321 (let ((symbol (widget-value widget)))
|
|
|
2322 (widget-put widget :custom-state (cond ((get symbol 'customized-face)
|
|
|
2323 'set)
|
|
|
2324 ((get symbol 'saved-face)
|
|
|
2325 'saved)
|
|
149
|
2326 ((get symbol 'face-defface-spec)
|
|
153
|
2327 'standard)
|
|
28
|
2328 (t
|
|
|
2329 'rogue)))))
|
|
|
2330
|
|
|
2331 (defun custom-face-action (widget &optional event)
|
|
|
2332 "Show the menu for `custom-face' WIDGET.
|
|
|
2333 Optional EVENT is the location for the menu."
|
|
|
2334 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
149
|
2335 (custom-toggle-hide widget)
|
|
28
|
2336 (let* ((completion-ignore-case t)
|
|
|
2337 (symbol (widget-get widget :value))
|
|
155
|
2338 (answer (widget-choose (concat "Operation on "
|
|
|
2339 (custom-unlispify-tag-name symbol))
|
|
149
|
2340 (custom-menu-filter custom-face-menu
|
|
|
2341 widget)
|
|
|
2342 event)))
|
|
28
|
2343 (if answer
|
|
|
2344 (funcall answer widget)))))
|
|
|
2345
|
|
|
2346 (defun custom-face-set (widget)
|
|
|
2347 "Make the face attributes in WIDGET take effect."
|
|
|
2348 (let* ((symbol (widget-value widget))
|
|
|
2349 (child (car (widget-get widget :children)))
|
|
|
2350 (value (widget-value child)))
|
|
|
2351 (put symbol 'customized-face value)
|
|
155
|
2352 (face-spec-set symbol value)
|
|
28
|
2353 (custom-face-state-set widget)
|
|
|
2354 (custom-redraw-magic widget)))
|
|
|
2355
|
|
|
2356 (defun custom-face-save (widget)
|
|
|
2357 "Make the face attributes in WIDGET default."
|
|
|
2358 (let* ((symbol (widget-value widget))
|
|
|
2359 (child (car (widget-get widget :children)))
|
|
|
2360 (value (widget-value child)))
|
|
155
|
2361 (face-spec-set symbol value)
|
|
28
|
2362 (put symbol 'saved-face value)
|
|
|
2363 (put symbol 'customized-face nil)
|
|
|
2364 (custom-face-state-set widget)
|
|
|
2365 (custom-redraw-magic widget)))
|
|
|
2366
|
|
|
2367 (defun custom-face-reset-saved (widget)
|
|
|
2368 "Restore WIDGET to the face's default attributes."
|
|
|
2369 (let* ((symbol (widget-value widget))
|
|
|
2370 (child (car (widget-get widget :children)))
|
|
|
2371 (value (get symbol 'saved-face)))
|
|
|
2372 (unless value
|
|
|
2373 (error "No saved value for this face"))
|
|
|
2374 (put symbol 'customized-face nil)
|
|
155
|
2375 (face-spec-set symbol value)
|
|
28
|
2376 (widget-value-set child value)
|
|
|
2377 (custom-face-state-set widget)
|
|
|
2378 (custom-redraw-magic widget)))
|
|
|
2379
|
|
153
|
2380 (defun custom-face-reset-standard (widget)
|
|
|
2381 "Restore WIDGET to the face's standard settings."
|
|
28
|
2382 (let* ((symbol (widget-value widget))
|
|
|
2383 (child (car (widget-get widget :children)))
|
|
149
|
2384 (value (get symbol 'face-defface-spec)))
|
|
28
|
2385 (unless value
|
|
153
|
2386 (error "No standard setting for this face"))
|
|
28
|
2387 (put symbol 'customized-face nil)
|
|
|
2388 (when (get symbol 'saved-face)
|
|
|
2389 (put symbol 'saved-face nil)
|
|
|
2390 (custom-save-all))
|
|
155
|
2391 (face-spec-set symbol value)
|
|
28
|
2392 (widget-value-set child value)
|
|
|
2393 (custom-face-state-set widget)
|
|
|
2394 (custom-redraw-magic widget)))
|
|
|
2395
|
|
|
2396 ;;; The `face' Widget.
|
|
|
2397
|
|
|
2398 (define-widget 'face 'default
|
|
|
2399 "Select and customize a face."
|
|
149
|
2400 :convert-widget 'widget-value-convert-widget
|
|
163
|
2401 :button-prefix 'widget-push-button-prefix
|
|
|
2402 :button-suffix 'widget-push-button-suffix
|
|
|
2403 :format "%t: %[select face%] %v"
|
|
28
|
2404 :tag "Face"
|
|
|
2405 :value 'default
|
|
|
2406 :value-create 'widget-face-value-create
|
|
|
2407 :value-delete 'widget-face-value-delete
|
|
149
|
2408 :value-get 'widget-value-value-get
|
|
|
2409 :validate 'widget-children-validate
|
|
28
|
2410 :action 'widget-face-action
|
|
|
2411 :match '(lambda (widget value) (symbolp value)))
|
|
|
2412
|
|
|
2413 (defun widget-face-value-create (widget)
|
|
|
2414 ;; Create a `custom-face' child.
|
|
|
2415 (let* ((symbol (widget-value widget))
|
|
163
|
2416 (custom-buffer-style 'face)
|
|
28
|
2417 (child (widget-create-child-and-convert
|
|
|
2418 widget 'custom-face
|
|
|
2419 :custom-level nil
|
|
|
2420 :value symbol)))
|
|
|
2421 (custom-magic-reset child)
|
|
|
2422 (setq custom-options (cons child custom-options))
|
|
|
2423 (widget-put widget :children (list child))))
|
|
|
2424
|
|
|
2425 (defun widget-face-value-delete (widget)
|
|
|
2426 ;; Remove the child from the options.
|
|
|
2427 (let ((child (car (widget-get widget :children))))
|
|
|
2428 (setq custom-options (delq child custom-options))
|
|
|
2429 (widget-children-value-delete widget)))
|
|
|
2430
|
|
|
2431 (defvar face-history nil
|
|
|
2432 "History of entered face names.")
|
|
|
2433
|
|
|
2434 (defun widget-face-action (widget &optional event)
|
|
|
2435 "Prompt for a face."
|
|
|
2436 (let ((answer (completing-read "Face: "
|
|
|
2437 (mapcar (lambda (face)
|
|
|
2438 (list (symbol-name face)))
|
|
|
2439 (face-list))
|
|
|
2440 nil nil nil
|
|
|
2441 'face-history)))
|
|
|
2442 (unless (zerop (length answer))
|
|
|
2443 (widget-value-set widget (intern answer))
|
|
|
2444 (widget-apply widget :notify widget event)
|
|
|
2445 (widget-setup))))
|
|
|
2446
|
|
|
2447 ;;; The `hook' Widget.
|
|
|
2448
|
|
|
2449 (define-widget 'hook 'list
|
|
|
2450 "A emacs lisp hook"
|
|
|
2451 :convert-widget 'custom-hook-convert-widget
|
|
|
2452 :tag "Hook")
|
|
|
2453
|
|
|
2454 (defun custom-hook-convert-widget (widget)
|
|
|
2455 ;; Handle `:custom-options'.
|
|
|
2456 (let* ((options (widget-get widget :options))
|
|
|
2457 (other `(editable-list :inline t
|
|
|
2458 :entry-format "%i %d%v"
|
|
|
2459 (function :format " %v")))
|
|
|
2460 (args (if options
|
|
|
2461 (list `(checklist :inline t
|
|
|
2462 ,@(mapcar (lambda (entry)
|
|
|
2463 `(function-item ,entry))
|
|
|
2464 options))
|
|
|
2465 other)
|
|
|
2466 (list other))))
|
|
|
2467 (widget-put widget :args args)
|
|
|
2468 widget))
|
|
|
2469
|
|
163
|
2470 ;;; The `custom-group-link' Widget.
|
|
|
2471
|
|
|
2472 (define-widget 'custom-group-link 'link
|
|
|
2473 "Show parent in other window when activated."
|
|
165
|
2474 :help-echo "Create customization buffer for this group."
|
|
163
|
2475 :action 'custom-group-link-action)
|
|
|
2476
|
|
|
2477 (defun custom-group-link-action (widget &rest ignore)
|
|
|
2478 (customize-group (widget-value widget)))
|
|
|
2479
|
|
28
|
2480 ;;; The `custom-group' Widget.
|
|
|
2481
|
|
165
|
2482 (defcustom custom-group-tag-faces nil
|
|
28
|
2483 ;; In XEmacs, this ought to play games with font size.
|
|
|
2484 "Face used for group tags.
|
|
|
2485 The first member is used for level 1 groups, the second for level 2,
|
|
|
2486 and so forth. The remaining group tags are shown with
|
|
|
2487 `custom-group-tag-face'."
|
|
|
2488 :type '(repeat face)
|
|
124
|
2489 :group 'custom-faces)
|
|
28
|
2490
|
|
|
2491 (defface custom-group-tag-face-1 '((((class color)
|
|
118
|
2492 (background dark))
|
|
|
2493 (:foreground "pink" :underline t))
|
|
|
2494 (((class color)
|
|
|
2495 (background light))
|
|
|
2496 (:foreground "red" :underline t))
|
|
|
2497 (t (:underline t)))
|
|
28
|
2498 "Face used for group tags.")
|
|
|
2499
|
|
|
2500 (defface custom-group-tag-face '((((class color)
|
|
|
2501 (background dark))
|
|
|
2502 (:foreground "light blue" :underline t))
|
|
|
2503 (((class color)
|
|
|
2504 (background light))
|
|
|
2505 (:foreground "blue" :underline t))
|
|
|
2506 (t (:underline t)))
|
|
|
2507 "Face used for low level group tags."
|
|
124
|
2508 :group 'custom-faces)
|
|
28
|
2509
|
|
|
2510 (define-widget 'custom-group 'custom
|
|
|
2511 "Customize group."
|
|
163
|
2512 :format "%v"
|
|
28
|
2513 :sample-face-get 'custom-group-sample-face-get
|
|
|
2514 :documentation-property 'group-documentation
|
|
30
|
2515 :help-echo "Set or reset all members of this group."
|
|
28
|
2516 :value-create 'custom-group-value-create
|
|
|
2517 :action 'custom-group-action
|
|
155
|
2518 :custom-category 'group
|
|
28
|
2519 :custom-set 'custom-group-set
|
|
|
2520 :custom-save 'custom-group-save
|
|
|
2521 :custom-reset-current 'custom-group-reset-current
|
|
|
2522 :custom-reset-saved 'custom-group-reset-saved
|
|
153
|
2523 :custom-reset-standard 'custom-group-reset-standard
|
|
28
|
2524 :custom-menu 'custom-group-menu-create)
|
|
|
2525
|
|
|
2526 (defun custom-group-sample-face-get (widget)
|
|
|
2527 ;; Use :sample-face.
|
|
|
2528 (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces)
|
|
|
2529 'custom-group-tag-face))
|
|
|
2530
|
|
165
|
2531 (define-widget 'custom-group-visibility 'visibility
|
|
|
2532 "An indicator and manipulator for hidden group contents."
|
|
|
2533 :create 'custom-group-visibility-create)
|
|
|
2534
|
|
|
2535 (defun custom-group-visibility-create (widget)
|
|
|
2536 (let ((visible (widget-value widget)))
|
|
|
2537 (if visible
|
|
|
2538 (insert "--------")))
|
|
|
2539 (widget-default-create widget))
|
|
|
2540
|
|
28
|
2541 (defun custom-group-value-create (widget)
|
|
163
|
2542 "Insert a customize group for WIDGET in the current buffer."
|
|
|
2543 (let ((state (widget-get widget :custom-state))
|
|
|
2544 (level (widget-get widget :custom-level))
|
|
|
2545 (indent (widget-get widget :indent))
|
|
|
2546 (prefix (widget-get widget :custom-prefix))
|
|
|
2547 (buttons (widget-get widget :buttons))
|
|
|
2548 (tag (widget-get widget :tag))
|
|
|
2549 (symbol (widget-value widget)))
|
|
|
2550 (cond ((and (eq custom-buffer-style 'tree)
|
|
167
|
2551 (eq state 'hidden)
|
|
|
2552 (or (get symbol 'custom-group)
|
|
|
2553 (custom-unloaded-widget-p widget)))
|
|
|
2554 (custom-browse-insert-prefix prefix)
|
|
163
|
2555 (push (widget-create-child-and-convert
|
|
167
|
2556 widget 'custom-browse-visibility
|
|
163
|
2557 ;; :tag-glyph "plus"
|
|
167
|
2558 :tag (if (custom-unloaded-widget-p widget) "?" "+"))
|
|
163
|
2559 buttons)
|
|
|
2560 (insert "-- ")
|
|
|
2561 ;; (widget-glyph-insert nil "-- " "horizontal")
|
|
|
2562 (push (widget-create-child-and-convert
|
|
167
|
2563 widget 'custom-browse-group-tag)
|
|
163
|
2564 buttons)
|
|
|
2565 (insert " " tag "\n")
|
|
|
2566 (widget-put widget :buttons buttons))
|
|
|
2567 ((and (eq custom-buffer-style 'tree)
|
|
|
2568 (zerop (length (get symbol 'custom-group))))
|
|
167
|
2569 (custom-browse-insert-prefix prefix)
|
|
163
|
2570 (insert "[ ]-- ")
|
|
|
2571 ;; (widget-glyph-insert nil "[ ]" "empty")
|
|
|
2572 ;; (widget-glyph-insert nil "-- " "horizontal")
|
|
|
2573 (push (widget-create-child-and-convert
|
|
167
|
2574 widget 'custom-browse-group-tag)
|
|
163
|
2575 buttons)
|
|
|
2576 (insert " " tag "\n")
|
|
|
2577 (widget-put widget :buttons buttons))
|
|
|
2578 ((eq custom-buffer-style 'tree)
|
|
167
|
2579 (custom-browse-insert-prefix prefix)
|
|
163
|
2580 (custom-load-widget widget)
|
|
|
2581 (if (zerop (length (get symbol 'custom-group)))
|
|
|
2582 (progn
|
|
167
|
2583 (custom-browse-insert-prefix prefix)
|
|
163
|
2584 (insert "[ ]-- ")
|
|
|
2585 ;; (widget-glyph-insert nil "[ ]" "empty")
|
|
|
2586 ;; (widget-glyph-insert nil "-- " "horizontal")
|
|
|
2587 (push (widget-create-child-and-convert
|
|
167
|
2588 widget 'custom-browse-group-tag)
|
|
163
|
2589 buttons)
|
|
|
2590 (insert " " tag "\n")
|
|
|
2591 (widget-put widget :buttons buttons))
|
|
|
2592 (push (widget-create-child-and-convert
|
|
167
|
2593 widget 'custom-browse-visibility
|
|
163
|
2594 ;; :tag-glyph "minus"
|
|
|
2595 :tag "-")
|
|
|
2596 buttons)
|
|
165
|
2597 (insert "-\\ ")
|
|
|
2598 ;; (widget-glyph-insert nil "-\\ " "top")
|
|
163
|
2599 (push (widget-create-child-and-convert
|
|
167
|
2600 widget 'custom-browse-group-tag)
|
|
163
|
2601 buttons)
|
|
|
2602 (insert " " tag "\n")
|
|
|
2603 (widget-put widget :buttons buttons)
|
|
|
2604 (message "Creating group...")
|
|
165
|
2605 (let* ((members (custom-sort-items (get symbol 'custom-group)
|
|
|
2606 custom-browse-sort-alphabetically
|
|
|
2607 custom-browse-order-groups))
|
|
163
|
2608 (prefixes (widget-get widget :custom-prefixes))
|
|
|
2609 (custom-prefix-list (custom-prefix-add symbol prefixes))
|
|
|
2610 (extra-prefix (if (widget-get widget :custom-last)
|
|
|
2611 " "
|
|
|
2612 " | "))
|
|
|
2613 (prefix (concat prefix extra-prefix))
|
|
|
2614 children entry)
|
|
|
2615 (while members
|
|
|
2616 (setq entry (car members)
|
|
|
2617 members (cdr members))
|
|
167
|
2618 (when (or (not custom-browse-only-groups)
|
|
|
2619 (eq (nth 1 entry) 'custom-group))
|
|
|
2620 (push (widget-create-child-and-convert
|
|
|
2621 widget (nth 1 entry)
|
|
|
2622 :group widget
|
|
|
2623 :tag (custom-unlispify-tag-name (nth 0 entry))
|
|
|
2624 :custom-prefixes custom-prefix-list
|
|
|
2625 :custom-level (1+ level)
|
|
|
2626 :custom-last (null members)
|
|
|
2627 :value (nth 0 entry)
|
|
|
2628 :custom-prefix prefix)
|
|
|
2629 children)))
|
|
163
|
2630 (widget-put widget :children (reverse children)))
|
|
|
2631 (message "Creating group...done")))
|
|
|
2632 ;; Nested style.
|
|
|
2633 ((eq state 'hidden)
|
|
|
2634 ;; Create level indicator.
|
|
165
|
2635 (unless (eq custom-buffer-style 'links)
|
|
|
2636 (insert-char ?\ (* custom-buffer-indent (1- level)))
|
|
|
2637 (insert "-- "))
|
|
163
|
2638 ;; Create tag.
|
|
|
2639 (let ((begin (point)))
|
|
|
2640 (insert tag)
|
|
|
2641 (widget-specify-sample widget begin (point)))
|
|
|
2642 (insert " group: ")
|
|
|
2643 ;; Create link/visibility indicator.
|
|
|
2644 (if (eq custom-buffer-style 'links)
|
|
|
2645 (push (widget-create-child-and-convert
|
|
|
2646 widget 'custom-group-link
|
|
165
|
2647 :tag "Go to Group"
|
|
163
|
2648 symbol)
|
|
|
2649 buttons)
|
|
|
2650 (push (widget-create-child-and-convert
|
|
165
|
2651 widget 'group-visibility
|
|
163
|
2652 :help-echo "Show members of this group."
|
|
|
2653 :action 'custom-toggle-parent
|
|
|
2654 (not (eq state 'hidden)))
|
|
|
2655 buttons))
|
|
|
2656 (insert " \n")
|
|
|
2657 ;; Create magic button.
|
|
|
2658 (let ((magic (widget-create-child-and-convert
|
|
|
2659 widget 'custom-magic nil)))
|
|
|
2660 (widget-put widget :custom-magic magic)
|
|
|
2661 (push magic buttons))
|
|
|
2662 ;; Update buttons.
|
|
|
2663 (widget-put widget :buttons buttons)
|
|
|
2664 ;; Insert documentation.
|
|
165
|
2665 (if (and (eq custom-buffer-style 'links) (> level 1))
|
|
|
2666 (widget-put widget :documentation-indent 0))
|
|
163
|
2667 (widget-default-format-handler widget ?h))
|
|
|
2668 ;; Nested style.
|
|
|
2669 (t ;Visible.
|
|
165
|
2670 ;; Add parent groups references above the group.
|
|
|
2671 (if t ;;; This should test that the buffer
|
|
|
2672 ;;; was made to display a group.
|
|
|
2673 (when (eq level 1)
|
|
|
2674 (if (custom-add-parent-links widget
|
|
|
2675 "Go to parent group:")
|
|
|
2676 (insert "\n"))))
|
|
163
|
2677 ;; Create level indicator.
|
|
|
2678 (insert-char ?\ (* custom-buffer-indent (1- level)))
|
|
|
2679 (insert "/- ")
|
|
|
2680 ;; Create tag.
|
|
|
2681 (let ((start (point)))
|
|
|
2682 (insert tag)
|
|
|
2683 (widget-specify-sample widget start (point)))
|
|
|
2684 (insert " group: ")
|
|
|
2685 ;; Create visibility indicator.
|
|
|
2686 (unless (eq custom-buffer-style 'links)
|
|
|
2687 (insert "--------")
|
|
|
2688 (push (widget-create-child-and-convert
|
|
|
2689 widget 'visibility
|
|
|
2690 :help-echo "Hide members of this group."
|
|
|
2691 :action 'custom-toggle-parent
|
|
|
2692 (not (eq state 'hidden)))
|
|
|
2693 buttons)
|
|
|
2694 (insert " "))
|
|
|
2695 ;; Create more dashes.
|
|
|
2696 ;; Use 76 instead of 75 to compensate for the temporary "<"
|
|
|
2697 ;; added by `widget-insert'.
|
|
|
2698 (insert-char ?- (- 76 (current-column)
|
|
|
2699 (* custom-buffer-indent level)))
|
|
|
2700 (insert "\\\n")
|
|
|
2701 ;; Create magic button.
|
|
|
2702 (let ((magic (widget-create-child-and-convert
|
|
|
2703 widget 'custom-magic
|
|
|
2704 :indent 0
|
|
|
2705 nil)))
|
|
|
2706 (widget-put widget :custom-magic magic)
|
|
|
2707 (push magic buttons))
|
|
|
2708 ;; Update buttons.
|
|
|
2709 (widget-put widget :buttons buttons)
|
|
|
2710 ;; Insert documentation.
|
|
|
2711 (widget-default-format-handler widget ?h)
|
|
165
|
2712 ;; Parent groups.
|
|
|
2713 (if nil ;;; This should test that the buffer
|
|
|
2714 ;;; was not made to display a group.
|
|
|
2715 (when (eq level 1)
|
|
|
2716 (insert-char ?\ custom-buffer-indent)
|
|
|
2717 (custom-add-parent-links widget)))
|
|
163
|
2718 (custom-add-see-also widget
|
|
|
2719 (make-string (* custom-buffer-indent level)
|
|
|
2720 ?\ ))
|
|
|
2721 ;; Members.
|
|
|
2722 (message "Creating group...")
|
|
|
2723 (custom-load-widget widget)
|
|
165
|
2724 (let* ((members (custom-sort-items (get symbol 'custom-group)
|
|
|
2725 custom-buffer-sort-alphabetically
|
|
|
2726 custom-buffer-order-groups))
|
|
163
|
2727 (prefixes (widget-get widget :custom-prefixes))
|
|
|
2728 (custom-prefix-list (custom-prefix-add symbol prefixes))
|
|
|
2729 (length (length members))
|
|
|
2730 (count 0)
|
|
|
2731 (children (mapcar (lambda (entry)
|
|
|
2732 (widget-insert "\n")
|
|
|
2733 (message "\
|
|
|
2734 Creating group members... %2d%%"
|
|
|
2735 (/ (* 100.0 count) length))
|
|
|
2736 (setq count (1+ count))
|
|
|
2737 (prog1
|
|
|
2738 (widget-create-child-and-convert
|
|
|
2739 widget (nth 1 entry)
|
|
|
2740 :group widget
|
|
|
2741 :tag (custom-unlispify-tag-name
|
|
|
2742 (nth 0 entry))
|
|
|
2743 :custom-prefixes custom-prefix-list
|
|
|
2744 :custom-level (1+ level)
|
|
|
2745 :value (nth 0 entry))
|
|
|
2746 (unless (eq (preceding-char) ?\n)
|
|
|
2747 (widget-insert "\n"))))
|
|
|
2748 members)))
|
|
|
2749 (message "Creating group magic...")
|
|
|
2750 (mapcar 'custom-magic-reset children)
|
|
|
2751 (message "Creating group state...")
|
|
|
2752 (widget-put widget :children children)
|
|
|
2753 (custom-group-state-update widget)
|
|
|
2754 (message "Creating group... done"))
|
|
|
2755 ;; End line
|
|
|
2756 (insert "\n")
|
|
|
2757 (insert-char ?\ (* custom-buffer-indent (1- level)))
|
|
|
2758 (insert "\\- " (widget-get widget :tag) " group end ")
|
|
|
2759 (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level)))
|
|
|
2760 (insert "/\n")))))
|
|
28
|
2761
|
|
|
2762 (defvar custom-group-menu
|
|
155
|
2763 '(("Set" custom-group-set
|
|
149
|
2764 (lambda (widget)
|
|
|
2765 (eq (widget-get widget :custom-state) 'modified)))
|
|
|
2766 ("Save" custom-group-save
|
|
|
2767 (lambda (widget)
|
|
|
2768 (memq (widget-get widget :custom-state) '(modified set))))
|
|
|
2769 ("Reset to Current" custom-group-reset-current
|
|
|
2770 (lambda (widget)
|
|
|
2771 (memq (widget-get widget :custom-state) '(modified))))
|
|
|
2772 ("Reset to Saved" custom-group-reset-saved
|
|
|
2773 (lambda (widget)
|
|
|
2774 (memq (widget-get widget :custom-state) '(modified set))))
|
|
153
|
2775 ("Reset to standard setting" custom-group-reset-standard
|
|
149
|
2776 (lambda (widget)
|
|
|
2777 (memq (widget-get widget :custom-state) '(modified set saved)))))
|
|
28
|
2778 "Alist of actions for the `custom-group' widget.
|
|
149
|
2779 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
|
|
|
2780 the menu entry, ACTION is the function to call on the widget when the
|
|
|
2781 menu is selected, and FILTER is a predicate which takes a `custom-group'
|
|
|
2782 widget as an argument, and returns non-nil if ACTION is valid on that
|
|
|
2783 widget. If FILTER is nil, ACTION is always valid.")
|
|
28
|
2784
|
|
|
2785 (defun custom-group-action (widget &optional event)
|
|
|
2786 "Show the menu for `custom-group' WIDGET.
|
|
|
2787 Optional EVENT is the location for the menu."
|
|
|
2788 (if (eq (widget-get widget :custom-state) 'hidden)
|
|
149
|
2789 (custom-toggle-hide widget)
|
|
28
|
2790 (let* ((completion-ignore-case t)
|
|
155
|
2791 (answer (widget-choose (concat "Operation on "
|
|
|
2792 (custom-unlispify-tag-name
|
|
|
2793 (widget-get widget :value)))
|
|
149
|
2794 (custom-menu-filter custom-group-menu
|
|
|
2795 widget)
|
|
28
|
2796 event)))
|
|
|
2797 (if answer
|
|
|
2798 (funcall answer widget)))))
|
|
|
2799
|
|
|
2800 (defun custom-group-set (widget)
|
|
|
2801 "Set changes in all modified group members."
|
|
|
2802 (let ((children (widget-get widget :children)))
|
|
|
2803 (mapcar (lambda (child)
|
|
|
2804 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
2805 (widget-apply child :custom-set)))
|
|
|
2806 children )))
|
|
|
2807
|
|
|
2808 (defun custom-group-save (widget)
|
|
|
2809 "Save all modified group members."
|
|
|
2810 (let ((children (widget-get widget :children)))
|
|
|
2811 (mapcar (lambda (child)
|
|
|
2812 (when (memq (widget-get child :custom-state) '(modified set))
|
|
|
2813 (widget-apply child :custom-save)))
|
|
|
2814 children )))
|
|
|
2815
|
|
|
2816 (defun custom-group-reset-current (widget)
|
|
|
2817 "Reset all modified group members."
|
|
|
2818 (let ((children (widget-get widget :children)))
|
|
|
2819 (mapcar (lambda (child)
|
|
|
2820 (when (eq (widget-get child :custom-state) 'modified)
|
|
|
2821 (widget-apply child :custom-reset-current)))
|
|
|
2822 children )))
|
|
|
2823
|
|
|
2824 (defun custom-group-reset-saved (widget)
|
|
|
2825 "Reset all modified or set group members."
|
|
|
2826 (let ((children (widget-get widget :children)))
|
|
|
2827 (mapcar (lambda (child)
|
|
|
2828 (when (memq (widget-get child :custom-state) '(modified set))
|
|
|
2829 (widget-apply child :custom-reset-saved)))
|
|
|
2830 children )))
|
|
|
2831
|
|
153
|
2832 (defun custom-group-reset-standard (widget)
|
|
28
|
2833 "Reset all modified, set, or saved group members."
|
|
|
2834 (let ((children (widget-get widget :children)))
|
|
|
2835 (mapcar (lambda (child)
|
|
|
2836 (when (memq (widget-get child :custom-state)
|
|
|
2837 '(modified set saved))
|
|
153
|
2838 (widget-apply child :custom-reset-standard)))
|
|
28
|
2839 children )))
|
|
|
2840
|
|
|
2841 (defun custom-group-state-update (widget)
|
|
|
2842 "Update magic."
|
|
|
2843 (unless (eq (widget-get widget :custom-state) 'hidden)
|
|
|
2844 (let* ((children (widget-get widget :children))
|
|
|
2845 (states (mapcar (lambda (child)
|
|
|
2846 (widget-get child :custom-state))
|
|
|
2847 children))
|
|
|
2848 (magics custom-magic-alist)
|
|
153
|
2849 (found 'standard))
|
|
28
|
2850 (while magics
|
|
|
2851 (let ((magic (car (car magics))))
|
|
|
2852 (if (and (not (eq magic 'hidden))
|
|
|
2853 (memq magic states))
|
|
|
2854 (setq found magic
|
|
|
2855 magics nil)
|
|
|
2856 (setq magics (cdr magics)))))
|
|
|
2857 (widget-put widget :custom-state found)))
|
|
|
2858 (custom-magic-reset widget))
|
|
|
2859
|
|
|
2860 ;;; The `custom-save-all' Function.
|
|
163
|
2861 ;;;###autoload
|
|
171
|
2862 (defcustom custom-file (if (boundp 'emacs-user-extension-dir)
|
|
|
2863 (concat emacs-user-extension-dir "options.el")
|
|
163
|
2864 "~/.emacs")
|
|
28
|
2865 "File used for storing customization information.
|
|
|
2866 If you change this from the default \"~/.emacs\" you need to
|
|
|
2867 explicitly load that file for the settings to take effect."
|
|
|
2868 :type 'file
|
|
|
2869 :group 'customize)
|
|
|
2870
|
|
|
2871 (defun custom-save-delete (symbol)
|
|
|
2872 "Delete the call to SYMBOL form `custom-file'.
|
|
|
2873 Leave point at the location of the call, or after the last expression."
|
|
|
2874 (set-buffer (find-file-noselect custom-file))
|
|
|
2875 (goto-char (point-min))
|
|
|
2876 (catch 'found
|
|
|
2877 (while t
|
|
|
2878 (let ((sexp (condition-case nil
|
|
|
2879 (read (current-buffer))
|
|
|
2880 (end-of-file (throw 'found nil)))))
|
|
|
2881 (when (and (listp sexp)
|
|
|
2882 (eq (car sexp) symbol))
|
|
|
2883 (delete-region (save-excursion
|
|
|
2884 (backward-sexp)
|
|
|
2885 (point))
|
|
|
2886 (point))
|
|
|
2887 (throw 'found nil))))))
|
|
|
2888
|
|
|
2889 (defun custom-save-variables ()
|
|
|
2890 "Save all customized variables in `custom-file'."
|
|
|
2891 (save-excursion
|
|
|
2892 (custom-save-delete 'custom-set-variables)
|
|
|
2893 (let ((standard-output (current-buffer)))
|
|
|
2894 (unless (bolp)
|
|
|
2895 (princ "\n"))
|
|
|
2896 (princ "(custom-set-variables")
|
|
|
2897 (mapatoms (lambda (symbol)
|
|
167
|
2898 (let ((value (condition-case nil
|
|
|
2899 (get symbol 'saved-value)
|
|
|
2900 (t (progn
|
|
|
2901 (message "Bad plist in %s"
|
|
|
2902 (symbol-name symbol))
|
|
|
2903 nil))))
|
|
149
|
2904 (requests (get symbol 'custom-requests))
|
|
153
|
2905 (now (not (or (get symbol 'standard-value)
|
|
149
|
2906 (and (not (boundp symbol))
|
|
|
2907 (not (get symbol 'force-value)))))))
|
|
28
|
2908 (when value
|
|
|
2909 (princ "\n '(")
|
|
|
2910 (princ symbol)
|
|
|
2911 (princ " ")
|
|
|
2912 (prin1 (car value))
|
|
149
|
2913 (cond (requests
|
|
|
2914 (if now
|
|
|
2915 (princ " t ")
|
|
|
2916 (princ " nil "))
|
|
|
2917 (prin1 requests)
|
|
|
2918 (princ ")"))
|
|
|
2919 (now
|
|
|
2920 (princ " t)"))
|
|
|
2921 (t
|
|
|
2922 (princ ")")))))))
|
|
28
|
2923 (princ ")")
|
|
120
|
2924 (unless (looking-at "\n")
|
|
28
|
2925 (princ "\n")))))
|
|
|
2926
|
|
|
2927 (defun custom-save-faces ()
|
|
|
2928 "Save all customized faces in `custom-file'."
|
|
|
2929 (save-excursion
|
|
|
2930 (custom-save-delete 'custom-set-faces)
|
|
|
2931 (let ((standard-output (current-buffer)))
|
|
|
2932 (unless (bolp)
|
|
|
2933 (princ "\n"))
|
|
|
2934 (princ "(custom-set-faces")
|
|
120
|
2935 (let ((value (get 'default 'saved-face)))
|
|
|
2936 ;; The default face must be first, since it affects the others.
|
|
|
2937 (when value
|
|
|
2938 (princ "\n '(default ")
|
|
|
2939 (prin1 value)
|
|
149
|
2940 (if (or (get 'default 'face-defface-spec)
|
|
120
|
2941 (and (not (custom-facep 'default))
|
|
|
2942 (not (get 'default 'force-face))))
|
|
|
2943 (princ ")")
|
|
|
2944 (princ " t)"))))
|
|
28
|
2945 (mapatoms (lambda (symbol)
|
|
167
|
2946 (let ((value (condition-case nil
|
|
|
2947 (get symbol 'saved-face)
|
|
|
2948 (t (progn
|
|
|
2949 (message "Bad plist in %s"
|
|
|
2950 (symbol-name symbol)))
|
|
|
2951 nil))))
|
|
120
|
2952 (when (and (not (eq symbol 'default))
|
|
|
2953 ;; Don't print default face here.
|
|
|
2954 value)
|
|
28
|
2955 (princ "\n '(")
|
|
|
2956 (princ symbol)
|
|
|
2957 (princ " ")
|
|
|
2958 (prin1 value)
|
|
149
|
2959 (if (or (get symbol 'face-defface-spec)
|
|
28
|
2960 (and (not (custom-facep symbol))
|
|
|
2961 (not (get symbol 'force-face))))
|
|
|
2962 (princ ")")
|
|
|
2963 (princ " t)"))))))
|
|
|
2964 (princ ")")
|
|
120
|
2965 (unless (looking-at "\n")
|
|
28
|
2966 (princ "\n")))))
|
|
|
2967
|
|
116
|
2968 ;;;###autoload
|
|
165
|
2969 (defun customize-save-customized ()
|
|
149
|
2970 "Save all user options which have been set in this session."
|
|
|
2971 (interactive)
|
|
|
2972 (mapatoms (lambda (symbol)
|
|
167
|
2973 (condition-case nil
|
|
|
2974 (let ((face (get symbol 'customized-face))
|
|
|
2975 (value (get symbol 'customized-value)))
|
|
|
2976 (when face
|
|
|
2977 (put symbol 'saved-face face)
|
|
|
2978 (put symbol 'customized-face nil))
|
|
|
2979 (when value
|
|
|
2980 (put symbol 'saved-value value)
|
|
|
2981 (put symbol 'customized-value nil)))
|
|
|
2982 (t (message "Bad plist in %s"
|
|
|
2983 (symbol-name symbol))))))
|
|
149
|
2984 ;; We really should update all custom buffers here.
|
|
|
2985 (custom-save-all))
|
|
|
2986
|
|
|
2987 ;;;###autoload
|
|
28
|
2988 (defun custom-save-all ()
|
|
|
2989 "Save all customizations in `custom-file'."
|
|
|
2990 (custom-save-variables)
|
|
|
2991 (custom-save-faces)
|
|
|
2992 (save-excursion
|
|
|
2993 (set-buffer (find-file-noselect custom-file))
|
|
|
2994 (save-buffer)))
|
|
|
2995
|
|
|
2996 ;;; The Customize Menu.
|
|
|
2997
|
|
120
|
2998 ;;; Menu support
|
|
|
2999
|
|
|
3000 (unless (string-match "XEmacs" emacs-version)
|
|
163
|
3001 (defconst custom-help-menu
|
|
|
3002 '("Customize"
|
|
167
|
3003 ["Update menu" Custom-menu-update t]
|
|
|
3004 ["Browse" (customize-browse 'emacs) t]
|
|
163
|
3005 ["Group..." customize-group t]
|
|
167
|
3006 ["Option..." customize-option t]
|
|
163
|
3007 ["Face..." customize-face t]
|
|
|
3008 ["Saved..." customize-saved t]
|
|
|
3009 ["Set..." customize-customized t]
|
|
167
|
3010 "--"
|
|
163
|
3011 ["Apropos..." customize-apropos t]
|
|
|
3012 ["Group apropos..." customize-apropos-groups t]
|
|
167
|
3013 ["Option apropos..." customize-apropos-options t]
|
|
163
|
3014 ["Face apropos..." customize-apropos-faces t])
|
|
120
|
3015 ;; This menu should be identical to the one defined in `menu-bar.el'.
|
|
|
3016 "Customize menu")
|
|
|
3017
|
|
|
3018 (defun custom-menu-reset ()
|
|
|
3019 "Reset customize menu."
|
|
|
3020 (remove-hook 'custom-define-hook 'custom-menu-reset)
|
|
|
3021 (define-key global-map [menu-bar help-menu customize-menu]
|
|
|
3022 (cons (car custom-help-menu)
|
|
|
3023 (easy-menu-create-keymaps (car custom-help-menu)
|
|
|
3024 (cdr custom-help-menu)))))
|
|
|
3025
|
|
165
|
3026 (defun Custom-menu-update (event)
|
|
120
|
3027 "Update customize menu."
|
|
|
3028 (interactive "e")
|
|
|
3029 (add-hook 'custom-define-hook 'custom-menu-reset)
|
|
|
3030 (let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs))
|
|
|
3031 (menu `(,(car custom-help-menu)
|
|
|
3032 ,emacs
|
|
|
3033 ,@(cdr (cdr custom-help-menu)))))
|
|
|
3034 (let ((map (easy-menu-create-keymaps (car menu) (cdr menu))))
|
|
|
3035 (define-key global-map [menu-bar help-menu customize-menu]
|
|
153
|
3036 (cons (car menu) map))))))
|
|
120
|
3037
|
|
153
|
3038 (defcustom custom-menu-nesting 2
|
|
|
3039 "Maximum nesting in custom menus."
|
|
|
3040 :type 'integer
|
|
161
|
3041 :group 'custom-menu)
|
|
28
|
3042
|
|
|
3043 (defun custom-face-menu-create (widget symbol)
|
|
|
3044 "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
|
|
|
3045 (vector (custom-unlispify-menu-entry symbol)
|
|
149
|
3046 `(customize-face ',symbol)
|
|
28
|
3047 t))
|
|
|
3048
|
|
|
3049 (defun custom-variable-menu-create (widget symbol)
|
|
|
3050 "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
|
|
|
3051 (let ((type (get symbol 'custom-type)))
|
|
|
3052 (unless (listp type)
|
|
|
3053 (setq type (list type)))
|
|
|
3054 (if (and type (widget-get type :custom-menu))
|
|
|
3055 (widget-apply type :custom-menu symbol)
|
|
|
3056 (vector (custom-unlispify-menu-entry symbol)
|
|
149
|
3057 `(customize-variable ',symbol)
|
|
28
|
3058 t))))
|
|
|
3059
|
|
120
|
3060 ;; Add checkboxes to boolean variable entries.
|
|
28
|
3061 (widget-put (get 'boolean 'widget-type)
|
|
|
3062 :custom-menu (lambda (widget symbol)
|
|
|
3063 (vector (custom-unlispify-menu-entry symbol)
|
|
149
|
3064 `(customize-variable ',symbol)
|
|
28
|
3065 ':style 'toggle
|
|
|
3066 ':selected symbol)))
|
|
|
3067
|
|
34
|
3068 (if (string-match "XEmacs" emacs-version)
|
|
|
3069 ;; XEmacs can create menus dynamically.
|
|
|
3070 (defun custom-group-menu-create (widget symbol)
|
|
|
3071 "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
|
|
|
3072 `( ,(custom-unlispify-menu-entry symbol t)
|
|
36
|
3073 :filter (lambda (&rest junk)
|
|
|
3074 (cdr (custom-menu-create ',symbol)))))
|
|
34
|
3075 ;; But emacs can't.
|
|
|
3076 (defun custom-group-menu-create (widget symbol)
|
|
|
3077 "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
|
|
|
3078 ;; Limit the nesting.
|
|
|
3079 (let ((custom-menu-nesting (1- custom-menu-nesting)))
|
|
|
3080 (custom-menu-create symbol))))
|
|
28
|
3081
|
|
120
|
3082 ;;;###autoload
|
|
124
|
3083 (defun custom-menu-create (symbol)
|
|
28
|
3084 "Create menu for customization group SYMBOL.
|
|
|
3085 The menu is in a format applicable to `easy-menu-define'."
|
|
124
|
3086 (let* ((item (vector (custom-unlispify-menu-entry symbol)
|
|
153
|
3087 `(customize-group ',symbol)
|
|
124
|
3088 t)))
|
|
120
|
3089 (if (and (or (not (boundp 'custom-menu-nesting))
|
|
|
3090 (>= custom-menu-nesting 0))
|
|
28
|
3091 (< (length (get symbol 'custom-group)) widget-menu-max-size))
|
|
34
|
3092 (let ((custom-prefix-list (custom-prefix-add symbol
|
|
155
|
3093 custom-prefix-list))
|
|
165
|
3094 (members (custom-sort-items (get symbol 'custom-group)
|
|
|
3095 custom-menu-sort-alphabetically
|
|
|
3096 custom-menu-order-groups)))
|
|
28
|
3097 (custom-load-symbol symbol)
|
|
|
3098 `(,(custom-unlispify-menu-entry symbol t)
|
|
|
3099 ,item
|
|
|
3100 "--"
|
|
|
3101 ,@(mapcar (lambda (entry)
|
|
|
3102 (widget-apply (if (listp (nth 1 entry))
|
|
|
3103 (nth 1 entry)
|
|
|
3104 (list (nth 1 entry)))
|
|
|
3105 :custom-menu (nth 0 entry)))
|
|
155
|
3106 members)))
|
|
28
|
3107 item)))
|
|
|
3108
|
|
124
|
3109 ;;;###autoload
|
|
|
3110 (defun customize-menu-create (symbol &optional name)
|
|
|
3111 "Return a customize menu for customization group SYMBOL.
|
|
|
3112 If optional NAME is given, use that as the name of the menu.
|
|
|
3113 Otherwise the menu will be named `Customize'.
|
|
|
3114 The format is suitable for use with `easy-menu-define'."
|
|
|
3115 (unless name
|
|
|
3116 (setq name "Customize"))
|
|
|
3117 (if (string-match "XEmacs" emacs-version)
|
|
|
3118 ;; We can delay it under XEmacs.
|
|
|
3119 `(,name
|
|
|
3120 :filter (lambda (&rest junk)
|
|
|
3121 (cdr (custom-menu-create ',symbol))))
|
|
|
3122 ;; But we must create it now under Emacs.
|
|
|
3123 (cons name (cdr (custom-menu-create symbol)))))
|
|
|
3124
|
|
|
3125 ;;; The Custom Mode.
|
|
|
3126
|
|
|
3127 (defvar custom-mode-map nil
|
|
|
3128 "Keymap for `custom-mode'.")
|
|
165
|
3129
|
|
124
|
3130 (unless custom-mode-map
|
|
|
3131 (setq custom-mode-map (make-sparse-keymap))
|
|
|
3132 (set-keymap-parent custom-mode-map widget-keymap)
|
|
157
|
3133 (suppress-keymap custom-mode-map)
|
|
165
|
3134 (define-key custom-mode-map " " 'scroll-up)
|
|
|
3135 (define-key custom-mode-map "\177" 'scroll-down)
|
|
|
3136 (define-key custom-mode-map "q" 'bury-buffer)
|
|
|
3137 (define-key custom-mode-map "u" 'Custom-goto-parent))
|
|
124
|
3138
|
|
165
|
3139 (easy-menu-define Custom-mode-menu
|
|
124
|
3140 custom-mode-map
|
|
|
3141 "Menu used in customization buffers."
|
|
|
3142 `("Custom"
|
|
163
|
3143 ,(customize-menu-create 'customize)
|
|
165
|
3144 ["Set" Custom-set t]
|
|
|
3145 ["Save" Custom-save t]
|
|
|
3146 ["Reset to Current" Custom-reset-current t]
|
|
|
3147 ["Reset to Saved" Custom-reset-saved t]
|
|
|
3148 ["Reset to Standard Settings" Custom-reset-standard t]
|
|
124
|
3149 ["Info" (Info-goto-node "(custom)The Customization Buffer") t]))
|
|
|
3150
|
|
165
|
3151 (defun Custom-goto-parent ()
|
|
|
3152 "Go to the parent group listed at the top of this buffer.
|
|
|
3153 If several parents are listed, go to the first of them."
|
|
|
3154 (interactive)
|
|
|
3155 (save-excursion
|
|
|
3156 (goto-char (point-min))
|
|
|
3157 (if (search-forward "\nGo to parent group: " nil t)
|
|
|
3158 (let* ((button (get-char-property (point) 'button))
|
|
|
3159 (parent (downcase (widget-get button :tag))))
|
|
|
3160 (customize-group parent)))))
|
|
|
3161
|
|
124
|
3162 (defcustom custom-mode-hook nil
|
|
|
3163 "Hook called when entering custom-mode."
|
|
|
3164 :type 'hook
|
|
161
|
3165 :group 'custom-buffer )
|
|
124
|
3166
|
|
165
|
3167 (defun custom-state-buffer-message (widget)
|
|
|
3168 (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified)
|
|
|
3169 (message "To install your edits, invoke [State] and choose the Set operation")))
|
|
|
3170
|
|
124
|
3171 (defun custom-mode ()
|
|
|
3172 "Major mode for editing customization buffers.
|
|
|
3173
|
|
|
3174 The following commands are available:
|
|
|
3175
|
|
|
3176 Move to next button or editable field. \\[widget-forward]
|
|
|
3177 Move to previous button or editable field. \\[widget-backward]
|
|
155
|
3178 Invoke button under the mouse pointer. \\[widget-button-click]
|
|
|
3179 Invoke button under point. \\[widget-button-press]
|
|
165
|
3180 Set all modifications. \\[Custom-set]
|
|
|
3181 Make all modifications default. \\[Custom-save]
|
|
|
3182 Reset all modified options. \\[Custom-reset-current]
|
|
|
3183 Reset all modified or set options. \\[Custom-reset-saved]
|
|
|
3184 Reset all options. \\[Custom-reset-standard]
|
|
124
|
3185
|
|
|
3186 Entry to this mode calls the value of `custom-mode-hook'
|
|
|
3187 if that value is non-nil."
|
|
|
3188 (kill-all-local-variables)
|
|
|
3189 (setq major-mode 'custom-mode
|
|
|
3190 mode-name "Custom")
|
|
|
3191 (use-local-map custom-mode-map)
|
|
165
|
3192 (easy-menu-add Custom-mode-menu)
|
|
124
|
3193 (make-local-variable 'custom-options)
|
|
165
|
3194 (make-local-variable 'widget-documentation-face)
|
|
|
3195 (setq widget-documentation-face 'custom-documentation-face)
|
|
|
3196 (make-local-hook 'widget-edit-functions)
|
|
|
3197 (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)
|
|
124
|
3198 (run-hooks 'custom-mode-hook))
|
|
28
|
3199
|
|
|
3200 ;;; The End.
|
|
|
3201
|
|
|
3202 (provide 'cus-edit)
|
|
|
3203
|
|
|
3204 ;; cus-edit.el ends here
|
