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