/[emacs]/emacs/lisp/cus-edit.el
ViewVC logotype

Contents of /emacs/lisp/cus-edit.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.321 - (show annotations) (download)
Thu Jun 14 23:08:20 2007 UTC (17 years ago) by cyd
Branch: MAIN
Changes since 1.320: +39 -30 lines
(custom-split-regexp-maybe): Simplify.
(custom-buffer-create-internal): Simplify message.
(custom-variable-tag): Reduce height to normal.
(custom-variable-value-create, custom-face-value-create)
(custom-visibility): New widget.
(custom-visibility): New face.
(custom-group-value-create): Call
widget-add-documentation-string-button, using `custom-visibility'.

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

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26