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