Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-edit.el @ 195:a2f645c6b9f8 r20-3b24

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b24
author cvs
date Mon, 13 Aug 2007 09:59:05 +0200
parents f53b5ca2e663
children acd284d43ca1
comparison
equal deleted inserted replaced
194:2947057885e5 195:a2f645c6b9f8
1 ;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages. 1 ;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages.
2 ;; 2 ;;
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
4 ;; 4 ;;
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
6 ;; Keywords: help, faces 7 ;; Keywords: help, faces
7 ;; Version: 1.9960 8 ;; Version: 1.9960-x
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
9 10
10 ;; This file is part of GNU Emacs. 11 ;; This file is part of XEmacs.
11 12
12 ;; GNU Emacs is free software; you can redistribute it and/or modify 13 ;; XEmacs 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 ;; 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 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version. 16 ;; any later version.
16 17
17 ;; GNU Emacs is distributed in the hope that it will be useful, 18 ;; XEmacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details. 21 ;; GNU General Public License for more details.
21 22
22 ;; You should have received a copy of the GNU General Public License 23 ;; 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 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA. 26 ;; Boston, MA 02111-1307, USA.
26 27
27 ;;; Commentary: 28 ;;; Commentary:
28 ;; 29 ;;
32 33
33 ;; No commands should have names starting with `custom-' because 34 ;; No commands should have names starting with `custom-' because
34 ;; that interferes with completion. Use `customize-' for commands 35 ;; that interferes with completion. Use `customize-' for commands
35 ;; that the user will run with M-x, and `Custom-' for interactive commands. 36 ;; that the user will run with M-x, and `Custom-' for interactive commands.
36 37
38
37 ;;; Code: 39 ;;; Code:
38 40
39 (require 'cus-face) 41 (require 'cus-face)
40 (require 'wid-edit) 42 (require 'wid-edit)
41 (require 'easymenu) 43 (require 'easymenu)
42 (eval-when-compile (require 'cl)) 44
43 45 (require 'cus-load)
44 (condition-case nil 46 (require 'cus-start)
45 (require 'cus-load) 47
46 (error nil)) 48 ;; Huh? This looks dirty!
47
48 (condition-case nil
49 (require 'cus-start)
50 (error nil))
51
52 (define-widget-keywords :custom-last :custom-prefix :custom-category
53 :custom-prefixes :custom-menu
54 :custom-show
55 :custom-magic :custom-state :custom-level :custom-form
56 :custom-set :custom-save :custom-reset-current :custom-reset-saved
57 :custom-reset-standard)
58
59 (put 'custom-define-hook 'custom-type 'hook) 49 (put 'custom-define-hook 'custom-type 'hook)
60 (put 'custom-define-hook 'standard-value '(nil)) 50 (put 'custom-define-hook 'standard-value '(nil))
61 (custom-add-to-group 'customize 'custom-define-hook 'custom-variable) 51 (custom-add-to-group 'customize 'custom-define-hook 'custom-variable)
62 52
63 ;;; Customization Groups. 53 ;;; Customization Groups.
64 54
65 (defgroup emacs nil 55 (defgroup emacs nil
66 "Customization of the One True Editor." 56 "Customization of the One True Editor."
67 :link '(custom-manual "(emacs)Top")) 57 :link '(custom-manual "(XEmacs)Top"))
68 58
69 ;; Most of these groups are stolen from `finder.el', 59 ;; Most of these groups are stolen from `finder.el',
70 (defgroup editing nil 60 (defgroup editing nil
71 "Basic text editing facilities." 61 "Basic text editing facilities."
72 :group 'emacs) 62 :group 'emacs)
349 339
350 (defgroup windows nil 340 (defgroup windows nil
351 "Windows within a frame." 341 "Windows within a frame."
352 :group 'environment) 342 :group 'environment)
353 343
344
354 ;;; Utilities. 345 ;;; Utilities.
355
356 (defun custom-last (x &optional n)
357 ;; Stolen from `cl.el'.
358 "Returns the last link in the list LIST.
359 With optional argument N, returns Nth-to-last link (default 1)."
360 (if n
361 (let ((m 0) (p x))
362 (while (consp p) (incf m) (pop p))
363 (if (<= n 0) p
364 (if (< n m) (nthcdr (- m n) x) x)))
365 (while (consp (cdr x)) (pop x))
366 x))
367 346
368 (defun custom-quote (sexp) 347 (defun custom-quote (sexp)
369 "Quote SEXP iff it is not self quoting." 348 "Quote SEXP iff it is not self quoting."
370 (if (or (memq sexp '(t nil)) 349 (if (or (memq sexp '(t nil))
371 (and (symbolp sexp) 350 (and (symbolp sexp)
411 (user-variable-p symbol)))))) 390 (user-variable-p symbol))))))
412 (list (if (equal val "") 391 (list (if (equal val "")
413 (if (symbolp v) v nil) 392 (if (symbolp v) v nil)
414 (intern val))))) 393 (intern val)))))
415 394
395 ;; Here we take not only the actual groups, but the loads, too.
396 (defun custom-group-prompt (prompt)
397 "Read group from minibuffer."
398 (let ((completion-ignore-case t))
399 (list (completing-read
400 prompt obarray
401 (lambda (symbol)
402 (or (get symbol 'custom-group)
403 (get symbol 'custom-loads)))
404 t))))
405
416 (defun custom-menu-filter (menu widget) 406 (defun custom-menu-filter (menu widget)
417 "Convert MENU to the form used by `widget-choose'. 407 "Convert MENU to the form used by `widget-choose'.
418 MENU should be in the same format as `custom-variable-menu'. 408 MENU should be in the same format as `custom-variable-menu'.
419 WIDGET is the widget to apply the filter entries of MENU on." 409 WIDGET is the widget to apply the filter entries of MENU on."
420 (let ((result nil) 410 (let ((result nil)
428 (if (or (null filter) (funcall filter widget)) 418 (if (or (null filter) (funcall filter widget))
429 (push (cons name action) result) 419 (push (cons name action) result)
430 (push name result))) 420 (push name result)))
431 (nreverse result))) 421 (nreverse result)))
432 422
423
433 ;;; Unlispify. 424 ;;; Unlispify.
434 425
435 (defvar custom-prefix-list nil 426 (defvar custom-prefix-list nil
436 "List of prefixes that should be ignored by `custom-unlispify'") 427 "List of prefixes that should be ignored by `custom-unlispify'")
437 428
438 (defcustom custom-unlispify-menu-entries t 429 (defcustom custom-unlispify-menu-entries t
439 "Display menu entries as words instead of symbols if non nil." 430 "Display menu entries as words instead of symbols if non nil."
440 :group 'custom-menu 431 :group 'custom-menu
441 :type 'boolean) 432 :type 'boolean)
442 433
443 (defcustom custom-unlispify-remove-prefixes nil 434 (defcustom custom-unlispify-remove-prefixes t
444 "Non-nil means remove group prefixes from option names in buffer." 435 "Non-nil means remove group prefixes from option names in buffers and menus."
445 :group 'custom-menu 436 :group 'custom-menu
446 :type 'boolean) 437 :type 'boolean)
447 438
448 (defun custom-unlispify-menu-entry (symbol &optional no-suffix) 439 (defun custom-unlispify-menu-entry (symbol &optional no-suffix)
449 "Convert symbol into a menu entry." 440 "Convert symbol into a menu entry."
452 ((get symbol 'custom-tag) 443 ((get symbol 'custom-tag)
453 (if no-suffix 444 (if no-suffix
454 (get symbol 'custom-tag) 445 (get symbol 'custom-tag)
455 (concat (get symbol 'custom-tag) "..."))) 446 (concat (get symbol 'custom-tag) "...")))
456 (t 447 (t
457 (save-excursion 448 (with-current-buffer (get-buffer-create " *Custom-Work*")
458 (set-buffer (get-buffer-create " *Custom-Work*"))
459 (erase-buffer) 449 (erase-buffer)
460 (princ symbol (current-buffer)) 450 (princ symbol (current-buffer))
461 (goto-char (point-min)) 451 (goto-char (point-min))
462 (when (and (eq (get symbol 'custom-type) 'boolean) 452 (when (and (eq (get symbol 'custom-type) 'boolean)
463 (re-search-forward "-p\\'" nil t)) 453 (re-search-forward "-p\\'" nil t))
464 (replace-match "" t t) 454 (replace-match "" t t)
465 (goto-char (point-min))) 455 (goto-char (point-min)))
466 (if custom-unlispify-remove-prefixes 456 (when custom-unlispify-remove-prefixes
467 (let ((prefixes custom-prefix-list) 457 (let ((prefixes custom-prefix-list)
468 prefix) 458 prefix)
469 (while prefixes 459 (while prefixes
470 (setq prefix (car prefixes)) 460 (setq prefix (car prefixes))
471 (if (search-forward prefix (+ (point) (length prefix)) t) 461 (if (search-forward prefix (+ (point) (length prefix)) t)
472 (progn 462 (progn
473 (setq prefixes nil) 463 (setq prefixes nil)
474 (delete-region (point-min) (point))) 464 (delete-region (point-min) (point)))
475 (setq prefixes (cdr prefixes)))))) 465 (setq prefixes (cdr prefixes))))))
476 (subst-char-in-region (point-min) (point-max) ?- ?\ t) 466 (subst-char-in-region (point-min) (point-max) ?- ?\ t)
477 (capitalize-region (point-min) (point-max)) 467 (capitalize-region (point-min) (point-max))
478 (unless no-suffix 468 (unless no-suffix
479 (goto-char (point-max)) 469 (goto-char (point-max))
480 (insert "...")) 470 (insert "..."))
494 ;; Addd SYMBOL to list of ignored PREFIXES. 484 ;; Addd SYMBOL to list of ignored PREFIXES.
495 (cons (or (get symbol 'custom-prefix) 485 (cons (or (get symbol 'custom-prefix)
496 (concat (symbol-name symbol) "-")) 486 (concat (symbol-name symbol) "-"))
497 prefixes)) 487 prefixes))
498 488
489
499 ;;; Guess. 490 ;;; Guess.
500 491
501 (defcustom custom-guess-name-alist 492 (defcustom custom-guess-name-alist
502 '(("-p\\'" boolean) 493 '(("-p\\'" boolean)
503 ("-hook\\'" hook) 494 ("-hook\\'" hook)
556 (when (string-match (nth 0 current) doc) 547 (when (string-match (nth 0 current) doc)
557 (setq found (nth 1 current) 548 (setq found (nth 1 current)
558 docs nil)))))) 549 docs nil))))))
559 found)) 550 found))
560 551
552
561 ;;; Sorting. 553 ;;; Sorting.
562 554
563 (defcustom custom-browse-sort-alphabetically nil 555 (defcustom custom-browse-sort-alphabetically nil
564 "If non-nil, sort members of each customization group alphabetically." 556 "If non-nil, sort members of each customization group alphabetically."
565 :type 'boolean 557 :type 'boolean
632 (eq order-groups 'last)) 624 (eq order-groups 'last))
633 (sort-alphabetically 625 (sort-alphabetically
634 ;; Since A and B cannot be groups, sort. 626 ;; Since A and B cannot be groups, sort.
635 (string-lessp namea nameb))))))) 627 (string-lessp namea nameb)))))))
636 628
629
637 ;;; Custom Mode Commands. 630 ;;; Custom Mode Commands.
638 631
639 (defvar custom-options nil 632 (defvar custom-options nil
640 "Customization widgets in the current buffer.") 633 "Customization widgets in the current buffer.")
641 634
642 (defun Custom-set () 635 (defun Custom-set ()
643 "Set changes in all modified options." 636 "Set changes in all modified options."
644 (interactive) 637 (interactive)
645 (let ((children custom-options)) 638 (let ((children custom-options))
646 (mapcar (lambda (child) 639 (mapc (lambda (child)
647 (when (eq (widget-get child :custom-state) 'modified) 640 (when (eq (widget-get child :custom-state) 'modified)
648 (widget-apply child :custom-set))) 641 (widget-apply child :custom-set)))
649 children))) 642 children)))
650 643
651 (defun Custom-save () 644 (defun Custom-save ()
652 "Set all modified group members and save them." 645 "Set all modified group members and save them."
653 (interactive) 646 (interactive)
654 (let ((children custom-options)) 647 (let ((children custom-options))
655 (mapcar (lambda (child) 648 (mapc (lambda (child)
656 (when (memq (widget-get child :custom-state) '(modified set)) 649 (when (memq (widget-get child :custom-state) '(modified set))
657 (widget-apply child :custom-save))) 650 (widget-apply child :custom-save)))
658 children)) 651 children))
659 (custom-save-all)) 652 (custom-save-all))
660 653
661 (defvar custom-reset-menu 654 (defvar custom-reset-menu
662 '(("Current" . Custom-reset-current) 655 '(("Current" . Custom-reset-current)
663 ("Saved" . Custom-reset-saved) 656 ("Saved" . Custom-reset-saved)
678 671
679 (defun Custom-reset-current (&rest ignore) 672 (defun Custom-reset-current (&rest ignore)
680 "Reset all modified group members to their current value." 673 "Reset all modified group members to their current value."
681 (interactive) 674 (interactive)
682 (let ((children custom-options)) 675 (let ((children custom-options))
683 (mapcar (lambda (child) 676 (mapc (lambda (child)
684 (when (eq (widget-get child :custom-state) 'modified) 677 (when (eq (widget-get child :custom-state) 'modified)
685 (widget-apply child :custom-reset-current))) 678 (widget-apply child :custom-reset-current)))
686 children))) 679 children)))
687 680
688 (defun Custom-reset-saved (&rest ignore) 681 (defun Custom-reset-saved (&rest ignore)
689 "Reset all modified or set group members to their saved value." 682 "Reset all modified or set group members to their saved value."
690 (interactive) 683 (interactive)
691 (let ((children custom-options)) 684 (let ((children custom-options))
692 (mapcar (lambda (child) 685 (mapc (lambda (child)
693 (when (eq (widget-get child :custom-state) 'modified) 686 (when (eq (widget-get child :custom-state) 'modified)
694 (widget-apply child :custom-reset-saved))) 687 (widget-apply child :custom-reset-saved)))
695 children))) 688 children)))
696 689
697 (defun Custom-reset-standard (&rest ignore) 690 (defun Custom-reset-standard (&rest ignore)
698 "Reset all modified, set, or saved group members to their standard settings." 691 "Reset all modified, set, or saved group members to their standard settings."
699 (interactive) 692 (interactive)
700 (let ((children custom-options)) 693 (let ((children custom-options))
701 (mapcar (lambda (child) 694 (mapc (lambda (child)
702 (when (eq (widget-get child :custom-state) 'modified) 695 (when (eq (widget-get child :custom-state) 'modified)
703 (widget-apply child :custom-reset-standard))) 696 (widget-apply child :custom-reset-standard)))
704 children))) 697 children)))
705 698
699
706 ;;; The Customize Commands 700 ;;; The Customize Commands
707 701
708 (defun custom-prompt-variable (prompt-var prompt-val) 702 (defun custom-prompt-variable (prompt-var prompt-val)
709 "Prompt for a variable and a value and return them as a list. 703 "Prompt for a variable and a value and return them as a list.
710 PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the 704 PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the
792 (funcall (or (get var 'custom-set) 'set-default) var val) 786 (funcall (or (get var 'custom-set) 'set-default) var val)
793 (put var 'saved-value (list (custom-quote val))) 787 (put var 'saved-value (list (custom-quote val)))
794 (custom-save-all)) 788 (custom-save-all))
795 789
796 ;;;###autoload 790 ;;;###autoload
797 (defun customize () 791 (defun customize (group)
798 "Select a customization buffer which you can use to set user options. 792 "Select a customization buffer which you can use to set user options.
799 User options are structured into \"groups\". 793 User options are structured into \"groups\".
800 Initially the top-level group `Emacs' and its immediate subgroups 794 The default group is `Emacs'."
801 are shown; the contents of those subgroups are initially hidden." 795 (interactive (custom-group-prompt
802 (interactive) 796 "Customize group: (default emacs) "))
803 (customize-group 'emacs))
804
805 ;;;###autoload
806 (defun customize-group (group)
807 "Customize GROUP, which must be a customization group."
808 (interactive (list (let ((completion-ignore-case t))
809 (completing-read "Customize group: (default emacs) "
810 obarray
811 (lambda (symbol)
812 (get symbol 'custom-group))
813 t))))
814
815 (when (stringp group) 797 (when (stringp group)
816 (if (string-equal "" group) 798 (if (string-equal "" group)
817 (setq group 'emacs) 799 (setq group 'emacs)
818 (setq group (intern group)))) 800 (setq group (intern group))))
819 (let ((name (format "*Customize Group: %s*" 801 (let ((name (format "*Customize Group: %s*"
824 name 806 name
825 (concat " for group " 807 (concat " for group "
826 (custom-unlispify-tag-name group)))))) 808 (custom-unlispify-tag-name group))))))
827 809
828 ;;;###autoload 810 ;;;###autoload
829 (defun customize-group-other-window (symbol) 811 (defalias 'customize-group 'customize)
812
813 ;;;###autoload
814 (defun customize-other-window (symbol)
830 "Customize SYMBOL, which must be a customization group." 815 "Customize SYMBOL, which must be a customization group."
831 (interactive (list (completing-read "Customize group: (default emacs) " 816 (interactive (custom-group-prompt
832 obarray 817 "Customize group: (default emacs) "))
833 (lambda (symbol)
834 (get symbol 'custom-group))
835 t)))
836
837 (when (stringp symbol) 818 (when (stringp symbol)
838 (if (string-equal "" symbol) 819 (if (string-equal "" symbol)
839 (setq symbol 'emacs) 820 (setq symbol 'emacs)
840 (setq symbol (intern symbol)))) 821 (setq symbol (intern symbol))))
841 (custom-buffer-create-other-window 822 (custom-buffer-create-other-window
842 (list (list symbol 'custom-group)) 823 (list (list symbol 'custom-group))
843 (format "*Customize Group: %s*" (custom-unlispify-tag-name symbol)))) 824 (format "*Customize Group: %s*" (custom-unlispify-tag-name symbol))))
844 825
845 ;;;###autoload 826 ;;;###autoload
846 (defalias 'customize-variable 'customize-option) 827 (defalias 'customize-group-other-window 'customize-other-window)
847 828
848 ;;;###autoload 829 ;;;###autoload
849 (defun customize-option (symbol) 830 (defalias 'customize-option 'customize-variable)
831
832 ;;;###autoload
833 (defun customize-variable (symbol)
850 "Customize SYMBOL, which must be a user option variable." 834 "Customize SYMBOL, which must be a user option variable."
851 (interactive (custom-variable-prompt)) 835 (interactive (custom-variable-prompt))
852 (custom-buffer-create (list (list symbol 'custom-variable)) 836 (custom-buffer-create (list (list symbol 'custom-variable))
853 (format "*Customize Option: %s*" 837 (format "*Customize Variable: %s*"
854 (custom-unlispify-tag-name symbol)))) 838 (custom-unlispify-tag-name symbol))))
855 839
856 ;;;###autoload 840 ;;;###autoload
857 (defalias 'customize-variable-other-window 'customize-option-other-window) 841 (defalias 'customize-variable-other-window 'customize-option-other-window)
858 842
868 ;;;###autoload 852 ;;;###autoload
869 (defun customize-face (&optional symbol) 853 (defun customize-face (&optional symbol)
870 "Customize SYMBOL, which should be a face name or nil. 854 "Customize SYMBOL, which should be a face name or nil.
871 If SYMBOL is nil, customize all faces." 855 If SYMBOL is nil, customize all faces."
872 (interactive (list (completing-read "Customize face: (default all) " 856 (interactive (list (completing-read "Customize face: (default all) "
873 obarray 'custom-facep))) 857 obarray 'find-face)))
874 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) 858 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
875 (custom-buffer-create (custom-sort-items 859 (custom-buffer-create (custom-sort-items
876 (mapcar (lambda (symbol) 860 (mapcar (lambda (symbol)
877 (list symbol 'custom-face)) 861 (list symbol 'custom-face))
878 (face-list)) 862 (face-list))
888 872
889 ;;;###autoload 873 ;;;###autoload
890 (defun customize-face-other-window (&optional symbol) 874 (defun customize-face-other-window (&optional symbol)
891 "Show customization buffer for FACE in other window." 875 "Show customization buffer for FACE in other window."
892 (interactive (list (completing-read "Customize face: " 876 (interactive (list (completing-read "Customize face: "
893 obarray 'custom-facep))) 877 obarray 'find-face)))
894 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) 878 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
895 () 879 ()
896 (if (stringp symbol) 880 (if (stringp symbol)
897 (setq symbol (intern symbol))) 881 (setq symbol (intern symbol)))
898 (unless (symbolp symbol) 882 (unless (symbolp symbol)
906 "Customize all user options set since the last save in this session." 890 "Customize all user options set since the last save in this session."
907 (interactive) 891 (interactive)
908 (let ((found nil)) 892 (let ((found nil))
909 (mapatoms (lambda (symbol) 893 (mapatoms (lambda (symbol)
910 (and (get symbol 'customized-face) 894 (and (get symbol 'customized-face)
911 (custom-facep symbol) 895 (find-face symbol)
912 (push (list symbol 'custom-face) found)) 896 (push (list symbol 'custom-face) found))
913 (and (get symbol 'customized-value) 897 (and (get symbol 'customized-value)
914 (boundp symbol) 898 (boundp symbol)
915 (push (list symbol 'custom-variable) found)))) 899 (push (list symbol 'custom-variable) found))))
916 (if (not found) 900 (if (not found)
923 "Customize all already saved user options." 907 "Customize all already saved user options."
924 (interactive) 908 (interactive)
925 (let ((found nil)) 909 (let ((found nil))
926 (mapatoms (lambda (symbol) 910 (mapatoms (lambda (symbol)
927 (and (get symbol 'saved-face) 911 (and (get symbol 'saved-face)
928 (custom-facep symbol) 912 (find-face symbol)
929 (push (list symbol 'custom-face) found)) 913 (push (list symbol 'custom-face) found))
930 (and (get symbol 'saved-value) 914 (and (get symbol 'saved-value)
931 (boundp symbol) 915 (boundp symbol)
932 (push (list symbol 'custom-variable) found)))) 916 (push (list symbol 'custom-variable) found))))
933 (if (not found ) 917 (if (not found )
949 (when (string-match regexp (symbol-name symbol)) 933 (when (string-match regexp (symbol-name symbol))
950 (when (and (not (memq all '(faces options))) 934 (when (and (not (memq all '(faces options)))
951 (get symbol 'custom-group)) 935 (get symbol 'custom-group))
952 (push (list symbol 'custom-group) found)) 936 (push (list symbol 'custom-group) found))
953 (when (and (not (memq all '(options groups))) 937 (when (and (not (memq all '(options groups)))
954 (custom-facep symbol)) 938 (find-face symbol))
955 (push (list symbol 'custom-face) found)) 939 (push (list symbol 'custom-face) found))
956 (when (and (not (memq all '(groups faces))) 940 (when (and (not (memq all '(groups faces)))
957 (boundp symbol) 941 (boundp symbol)
958 (or (get symbol 'saved-value) 942 (or (get symbol 'saved-value)
959 (get symbol 'standard-value) 943 (get symbol 'standard-value)
984 (defun customize-apropos-groups (regexp) 968 (defun customize-apropos-groups (regexp)
985 "Customize all user groups matching REGEXP." 969 "Customize all user groups matching REGEXP."
986 (interactive "sCustomize regexp: \n") 970 (interactive "sCustomize regexp: \n")
987 (customize-apropos regexp 'groups)) 971 (customize-apropos regexp 'groups))
988 972
973
989 ;;; Buffer. 974 ;;; Buffer.
990 975
991 (defcustom custom-buffer-style 'links 976 (defcustom custom-buffer-style 'links
992 "Control the presentation style for customization buffers. 977 "Control the presentation style for customization buffers.
993 The value should be a symbol, one of: 978 The value should be a symbol, one of:
994 979
995 brackets: groups nest within each other with big horizontal brackets. 980 brackets: groups nest within each other with big horizontal brackets.
996 links: groups have links to subgroups." 981 links: groups have links to subgroups."
997 :type '(radio (const brackets) 982 :type '(radio (const :tag "brackets: Groups nest within each others" brackets)
998 (const links)) 983 (const :tag "links: Group have links to subgroups" links))
999 :group 'custom-buffer) 984 :group 'custom-buffer)
1000 985
1001 (defcustom custom-buffer-indent 3 986 (defcustom custom-buffer-indent 3
1002 "Number of spaces to indent nested groups." 987 "Number of spaces to indent nested groups."
1003 :type 'integer 988 :type 'integer
1033 "If non-nil, only show a single reset button in customize buffers. 1018 "If non-nil, only show a single reset button in customize buffers.
1034 This button will have a menu with all three reset operations." 1019 This button will have a menu with all three reset operations."
1035 :type 'boolean 1020 :type 'boolean
1036 :group 'custom-buffer) 1021 :group 'custom-buffer)
1037 1022
1023 (defconst custom-skip-messages 5)
1024
1038 (defun custom-buffer-create-internal (options &optional description) 1025 (defun custom-buffer-create-internal (options &optional description)
1039 (message "Creating customization buffer...") 1026 (message "Creating customization buffer...")
1040 (custom-mode) 1027 (custom-mode)
1041 (widget-insert "This is a customization buffer") 1028 (widget-insert "This is a customization buffer")
1042 (if description 1029 (if description
1043 (widget-insert description)) 1030 (widget-insert description))
1044 (widget-insert ". 1031 (widget-insert ".\n\
1045 Square brackets show active fields; type RET or click mouse-2 1032 Type RET or click button2 on an active field to invoke its action.
1046 on an active field to invoke its action. Editing an option value
1047 changes the text in the buffer; invoke the State button and
1048 choose the Set operation to set the option value.
1049 Invoke ") 1033 Invoke ")
1050 (widget-create 'info-link 1034 (widget-create 'info-link
1051 :tag "Help" 1035 :tag "Help"
1052 :help-echo "Read the online help." 1036 :help-echo "Read the online help"
1053 "(emacs)Easy Customization") 1037 "(XEmacs)Easy Customization")
1054 (widget-insert " for more information.\n\n") 1038 (widget-insert " for more information.\n\n")
1055 (message "Creating customization buttons...") 1039 (message "Creating customization buttons...")
1056 (widget-insert "Operate on everything in this buffer:\n ") 1040 (widget-insert "Operate on everything in this buffer:\n ")
1057 (widget-create 'push-button 1041 (widget-create 'push-button
1058 :tag "Set for Current Session" 1042 :tag "Set"
1059 :help-echo "\ 1043 :help-echo "\
1060 Make your editing in this buffer take effect for this session." 1044 Make your editing in this buffer take effect for this session"
1061 :action (lambda (widget &optional event) 1045 :action (lambda (widget &optional event)
1062 (Custom-set))) 1046 (Custom-set)))
1063 (widget-insert " ") 1047 (widget-insert " ")
1064 (widget-create 'push-button 1048 (widget-create 'push-button
1065 :tag "Save for Future Sessions" 1049 :tag "Save"
1066 :help-echo "\ 1050 :help-echo "\
1067 Make your editing in this buffer take effect for future Emacs sessions." 1051 Make your editing in this buffer take effect for future Emacs sessions"
1068 :action (lambda (widget &optional event) 1052 :action (lambda (widget &optional event)
1069 (Custom-save))) 1053 (Custom-save)))
1070 (if custom-reset-button-menu 1054 (if custom-reset-button-menu
1071 (progn 1055 (progn
1072 (widget-insert " ") 1056 (widget-insert " ")
1073 (widget-create 'push-button 1057 (widget-create 'push-button
1074 :tag "Reset" 1058 :tag "Reset"
1075 :help-echo "Show a menu with reset operations." 1059 :help-echo "Show a menu with reset operations"
1076 :mouse-down-action (lambda (&rest junk) t) 1060 :mouse-down-action (lambda (&rest junk) t)
1077 :action (lambda (widget &optional event) 1061 :action (lambda (widget &optional event)
1078 (custom-reset event)))) 1062 (custom-reset event))))
1079 (widget-insert "\n ") 1063 (widget-insert " ")
1080 (widget-create 'push-button 1064 (widget-create 'push-button
1081 :tag "Reset" 1065 :tag "Reset"
1082 :help-echo "\ 1066 :help-echo "\
1083 Reset all edited text in this buffer to reflect current values." 1067 Reset all edited text in this buffer to reflect current values"
1084 :action 'Custom-reset-current) 1068 :action 'Custom-reset-current)
1085 (widget-insert " ") 1069 (widget-insert " ")
1086 (widget-create 'push-button 1070 (widget-create 'push-button
1087 :tag "Reset to Saved" 1071 :tag "Reset to Saved"
1088 :help-echo "\ 1072 :help-echo "\
1089 Reset all values in this buffer to their saved settings." 1073 Reset all values in this buffer to their saved settings"
1090 :action 'Custom-reset-saved) 1074 :action 'Custom-reset-saved)
1091 (widget-insert " ") 1075 (widget-insert " ")
1092 (widget-create 'push-button 1076 (widget-create 'push-button
1093 :tag "Reset to Standard" 1077 :tag "Reset to Standard"
1094 :help-echo "\ 1078 :help-echo "\
1095 Reset all values in this buffer to their standard settings." 1079 Reset all values in this buffer to their standard settings"
1096 :action 'Custom-reset-standard)) 1080 :action 'Custom-reset-standard))
1097 (widget-insert " ") 1081 (widget-insert " ")
1098 (widget-create 'push-button 1082 (widget-create 'push-button
1099 :tag "Bury Buffer" 1083 :tag "Done"
1100 :help-echo "Bury the buffer." 1084 :help-echo "Bury the buffer"
1101 :action (lambda (widget &optional event) 1085 :action (lambda (widget &optional event)
1102 (bury-buffer))) 1086 (bury-buffer)))
1103 (widget-insert "\n\n") 1087 (widget-insert "\n\n")
1104 (message "Creating customization items...") 1088 (message "Creating customization items...")
1105 (setq custom-options 1089 (setq custom-options
1113 :value (nth 0 entry))) 1097 :value (nth 0 entry)))
1114 options) 1098 options)
1115 (let ((count 0) 1099 (let ((count 0)
1116 (length (length options))) 1100 (length (length options)))
1117 (mapcar (lambda (entry) 1101 (mapcar (lambda (entry)
1118 (prog2 1102 (prog2
1119 (message "Creating customization items %2d%%..." 1103 (display-message
1120 (/ (* 100.0 count) length)) 1104 'progress
1121 (widget-create (nth 1 entry) 1105 (format "Creating customization items %2d%%..."
1106 (/ (* 100.0 count) length)))
1107 (widget-create (nth 1 entry)
1122 :tag (custom-unlispify-tag-name 1108 :tag (custom-unlispify-tag-name
1123 (nth 0 entry)) 1109 (nth 0 entry))
1124 :value (nth 0 entry)) 1110 :value (nth 0 entry))
1125 (setq count (1+ count)) 1111 (incf count)
1126 (unless (eq (preceding-char) ?\n) 1112 (unless (eq (preceding-char) ?\n)
1127 (widget-insert "\n")) 1113 (widget-insert "\n"))
1128 (widget-insert "\n"))) 1114 (widget-insert "\n")))
1129 options)))) 1115 options))))
1130 (unless (eq (preceding-char) ?\n) 1116 (unless (eq (preceding-char) ?\n)
1131 (widget-insert "\n")) 1117 (widget-insert "\n"))
1132 (message "Creating customization items %2d%%...done" 100) 1118 (display-message 'progress
1119 (format
1120 "Creating customization items %2d%%...done" 100))
1133 (unless (eq custom-buffer-style 'tree) 1121 (unless (eq custom-buffer-style 'tree)
1134 (mapcar 'custom-magic-reset custom-options)) 1122 (mapc 'custom-magic-reset custom-options))
1135 (message "Creating customization setup...") 1123 (message "Creating customization setup...")
1136 (widget-setup) 1124 (widget-setup)
1137 (goto-char (point-min)) 1125 (goto-char (point-min))
1138 (message "Creating customization buffer...done")) 1126 (message "Creating customization buffer...done"))
1139 1127
1128
1140 ;;; The Tree Browser. 1129 ;;; The Tree Browser.
1141 1130
1142 ;;;###autoload 1131 ;;;###autoload
1143 (defun customize-browse (&optional group) 1132 (defun customize-browse (&optional group)
1144 "Create a tree browser for the customize hierarchy." 1133 "Create a tree browser for the customize hierarchy."
1219 (defun custom-browse-face-tag-action (widget &rest ignore) 1208 (defun custom-browse-face-tag-action (widget &rest ignore)
1220 (let ((parent (widget-get widget :parent))) 1209 (let ((parent (widget-get widget :parent)))
1221 (customize-face-other-window (widget-value parent)))) 1210 (customize-face-other-window (widget-value parent))))
1222 1211
1223 (defconst custom-browse-alist '((" " "space") 1212 (defconst custom-browse-alist '((" " "space")
1224 (" | " "vertical") 1213 (" | " "vertical")
1225 ("-\\ " "top") 1214 ("-\\ " "top")
1226 (" |-" "middle") 1215 (" |-" "middle")
1227 (" `-" "bottom"))) 1216 (" `-" "bottom")))
1228 1217
1229 (defun custom-browse-insert-prefix (prefix) 1218 (defun custom-browse-insert-prefix (prefix)
1230 "Insert PREFIX. On XEmacs convert it to line graphics." 1219 "Insert PREFIX. On XEmacs convert it to line graphics."
1220 ;; ### Unfinished.
1231 (if nil ; (string-match "XEmacs" emacs-version) 1221 (if nil ; (string-match "XEmacs" emacs-version)
1232 (progn 1222 (progn
1233 (insert "*") 1223 (insert "*")
1234 (while (not (string-equal prefix "")) 1224 (while (not (string-equal prefix ""))
1235 (let ((entry (substring prefix 0 3))) 1225 (let ((entry (substring prefix 0 3)))
1239 (overlay-put overlay 'end-glyph (widget-glyph-find name entry)) 1229 (overlay-put overlay 'end-glyph (widget-glyph-find name entry))
1240 (overlay-put overlay 'start-open t) 1230 (overlay-put overlay 'start-open t)
1241 (overlay-put overlay 'end-open t))))) 1231 (overlay-put overlay 'end-open t)))))
1242 (insert prefix))) 1232 (insert prefix)))
1243 1233
1234
1244 ;;; Modification of Basic Widgets. 1235 ;;; Modification of Basic Widgets.
1245 ;; 1236 ;;
1246 ;; We add extra properties to the basic widgets needed here. This is 1237 ;; We add extra properties to the basic widgets needed here. This is
1247 ;; fine, as long as we are careful to stay within out own namespace. 1238 ;; fine, as long as we are careful to stay within out own namespace.
1248 ;; 1239 ;;
1262 1253
1263 ;;; The `custom-manual' Widget. 1254 ;;; The `custom-manual' Widget.
1264 1255
1265 (define-widget 'custom-manual 'info-link 1256 (define-widget 'custom-manual 'info-link
1266 "Link to the manual entry for this customization option." 1257 "Link to the manual entry for this customization option."
1267 :help-echo "Read the manual entry for this option."
1268 :tag "Manual") 1258 :tag "Manual")
1269 1259
1270 ;;; The `custom-magic' Widget. 1260 ;;; The `custom-magic' Widget.
1271 1261
1272 (defgroup custom-magic-faces nil 1262 (defgroup custom-magic-faces nil
1443 (> (widget-get parent :custom-level) 1)))) 1433 (> (widget-get parent :custom-level) 1))))
1444 (insert-char ?\ (* custom-buffer-indent 1434 (insert-char ?\ (* custom-buffer-indent
1445 (widget-get parent :custom-level)))) 1435 (widget-get parent :custom-level))))
1446 (push (widget-create-child-and-convert 1436 (push (widget-create-child-and-convert
1447 widget 'choice-item 1437 widget 'choice-item
1448 :help-echo "Change the state of this item." 1438 :help-echo "Change the state of this item"
1449 :format (if hidden "%t" "%[%t%]") 1439 :format (if hidden "%t" "%[%t%]")
1450 :button-prefix 'widget-push-button-prefix 1440 :button-prefix 'widget-push-button-prefix
1451 :button-suffix 'widget-push-button-suffix 1441 :button-suffix 'widget-push-button-suffix
1452 :mouse-down-action 'widget-magic-mouse-down-action 1442 :mouse-down-action 'widget-magic-mouse-down-action
1453 :tag "State") 1443 :tag "State")
1477 widget 'choice-item 1467 widget 'choice-item
1478 :mouse-down-action 'widget-magic-mouse-down-action 1468 :mouse-down-action 'widget-magic-mouse-down-action
1479 :button-face face 1469 :button-face face
1480 :button-prefix "" 1470 :button-prefix ""
1481 :button-suffix "" 1471 :button-suffix ""
1482 :help-echo "Change the state." 1472 :help-echo "Change the state"
1483 :format (if hidden "%t" "%[%t%]") 1473 :format (if hidden "%t" "%[%t%]")
1484 :tag (if (memq form '(lisp mismatch)) 1474 :tag (if (memq form '(lisp mismatch))
1485 (concat "(" magic ")") 1475 (concat "(" magic ")")
1486 (concat "[" magic "]"))) 1476 (concat "[" magic "]")))
1487 children) 1477 children)
1493 (let ((magic (widget-get widget :custom-magic))) 1483 (let ((magic (widget-get widget :custom-magic)))
1494 (widget-value-set magic (widget-value magic)))) 1484 (widget-value-set magic (widget-value magic))))
1495 1485
1496 ;;; The `custom' Widget. 1486 ;;; The `custom' Widget.
1497 1487
1498 (defface custom-button-face nil 1488 (defface custom-button-face '((t (:bold t)))
1499 "Face used for buttons in customization buffers." 1489 "Face used for buttons in customization buffers."
1500 :group 'custom-faces) 1490 :group 'custom-faces)
1501 1491
1502 (defface custom-documentation-face nil 1492 (defface custom-documentation-face nil
1503 "Face used for documentation strings in customization buffers." 1493 "Face used for documentation strings in customization buffers."
1698 (type (widget-type widget)) 1688 (type (widget-type widget))
1699 (buttons (widget-get widget :buttons)) 1689 (buttons (widget-get widget :buttons))
1700 (start (point)) 1690 (start (point))
1701 found) 1691 found)
1702 (insert (or initial-string "Parent groups:")) 1692 (insert (or initial-string "Parent groups:"))
1703 (mapatoms (lambda (symbol) 1693 (maphash (lambda (group ignore)
1704 (let ((entry (assq name (get symbol 'custom-group)))) 1694 (let ((entry (assq name (get group 'custom-group))))
1705 (when (eq (nth 1 entry) type) 1695 (when (eq (nth 1 entry) type)
1706 (insert " ") 1696 (insert " ")
1707 (push (widget-create-child-and-convert 1697 (push (widget-create-child-and-convert
1708 widget 'custom-group-link 1698 widget 'custom-group-link
1709 :tag (custom-unlispify-tag-name symbol) 1699 :tag (custom-unlispify-tag-name group)
1710 symbol) 1700 group)
1711 buttons) 1701 buttons)
1712 (setq found t))))) 1702 (setq found t))))
1703 custom-group-hash-table)
1713 (widget-put widget :buttons buttons) 1704 (widget-put widget :buttons buttons)
1714 (if found 1705 (if found
1715 (insert "\n") 1706 (insert "\n")
1716 (delete-region start (point))) 1707 (delete-region start (point)))
1717 found)) 1708 found))
1733 :group 'custom-faces) 1724 :group 'custom-faces)
1734 1725
1735 (define-widget 'custom-variable 'custom 1726 (define-widget 'custom-variable 'custom
1736 "Customize variable." 1727 "Customize variable."
1737 :format "%v" 1728 :format "%v"
1738 :help-echo "Set or reset this variable." 1729 :help-echo "Set or reset this variable"
1739 :documentation-property 'variable-documentation 1730 :documentation-property 'variable-documentation
1740 :custom-category 'option 1731 :custom-category 'option
1741 :custom-state nil 1732 :custom-state nil
1742 :custom-menu 'custom-variable-menu-create 1733 :custom-menu 'custom-variable-menu-create
1743 :custom-form 'edit 1734 :custom-form 'edit
1810 :tag tag 1801 :tag tag
1811 :parent widget) 1802 :parent widget)
1812 buttons) 1803 buttons)
1813 (push (widget-create-child-and-convert 1804 (push (widget-create-child-and-convert
1814 widget 'visibility 1805 widget 'visibility
1815 :help-echo "Show the value of this option." 1806 :help-echo "Show the value of this option"
1816 :action 'custom-toggle-parent 1807 :action 'custom-toggle-parent
1817 nil) 1808 nil)
1818 buttons)) 1809 buttons))
1819 ((memq form '(lisp mismatch)) 1810 ((memq form '(lisp mismatch))
1820 ;; In lisp mode edit the saved value when possible. 1811 ;; In lisp mode edit the saved value when possible.
1827 (t 1818 (t
1828 (custom-quote (widget-get conv :value)))))) 1819 (custom-quote (widget-get conv :value))))))
1829 (insert (symbol-name symbol) ": ") 1820 (insert (symbol-name symbol) ": ")
1830 (push (widget-create-child-and-convert 1821 (push (widget-create-child-and-convert
1831 widget 'visibility 1822 widget 'visibility
1832 :help-echo "Hide the value of this option." 1823 :help-echo "Hide the value of this option"
1833 :action 'custom-toggle-parent 1824 :action 'custom-toggle-parent
1834 t) 1825 t)
1835 buttons) 1826 buttons)
1836 (insert " ") 1827 (insert " ")
1837 (push (widget-create-child-and-convert 1828 (push (widget-create-child-and-convert
1852 (setq value-format (substring format (match-end 0))) 1843 (setq value-format (substring format (match-end 0)))
1853 (push (widget-create-child-and-convert 1844 (push (widget-create-child-and-convert
1854 widget 'item 1845 widget 'item
1855 :format tag-format 1846 :format tag-format
1856 :action 'custom-tag-action 1847 :action 'custom-tag-action
1857 :help-echo "Change value of this option." 1848 :help-echo "Change value of this option"
1858 :mouse-down-action 'custom-tag-mouse-down-action 1849 :mouse-down-action 'custom-tag-mouse-down-action
1859 :button-face 'custom-variable-button-face 1850 :button-face 'custom-variable-button-face
1860 :sample-face 'custom-variable-tag-face 1851 :sample-face 'custom-variable-tag-face
1861 tag) 1852 tag)
1862 buttons) 1853 buttons)
1863 (insert " ") 1854 (insert " ")
1864 (push (widget-create-child-and-convert 1855 (push (widget-create-child-and-convert
1865 widget 'visibility 1856 widget 'visibility
1866 :help-echo "Hide the value of this option." 1857 :help-echo "Hide the value of this option"
1867 :action 'custom-toggle-parent 1858 :action 'custom-toggle-parent
1868 t) 1859 t)
1869 buttons) 1860 buttons)
1870 (push (widget-create-child-and-convert 1861 (push (widget-create-child-and-convert
1871 widget type 1862 widget type
1958 '(modified set changed saved rogue))))) 1949 '(modified set changed saved rogue)))))
1959 ("---" ignore ignore) 1950 ("---" ignore ignore)
1960 ("Don't show as Lisp expression" custom-variable-edit 1951 ("Don't show as Lisp expression" custom-variable-edit
1961 (lambda (widget) 1952 (lambda (widget)
1962 (eq (widget-get widget :custom-form) 'lisp))) 1953 (eq (widget-get widget :custom-form) 'lisp)))
1963 ("Show initial Lisp expression" custom-variable-edit-lisp 1954 ("Show as Lisp expression" custom-variable-edit-lisp
1964 (lambda (widget) 1955 (lambda (widget)
1965 (eq (widget-get widget :custom-form) 'edit)))) 1956 (eq (widget-get widget :custom-form) 'edit))))
1966 "Alist of actions for the `custom-variable' widget. 1957 "Alist of actions for the `custom-variable' widget.
1967 Each entry has the form (NAME ACTION FILTER) where NAME is the name of 1958 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
1968 the menu entry, ACTION is the function to call on the widget when the 1959 the menu entry, ACTION is the function to call on the widget when the
2080 (define-widget 'custom-face-edit 'checklist 2071 (define-widget 'custom-face-edit 'checklist
2081 "Edit face attributes." 2072 "Edit face attributes."
2082 :format "%t: %v" 2073 :format "%t: %v"
2083 :tag "Attributes" 2074 :tag "Attributes"
2084 :extra-offset 12 2075 :extra-offset 12
2085 :button-args '(:help-echo "Control whether this attribute have any effect.") 2076 :button-args '(:help-echo "Control whether this attribute have any effect")
2086 :args (mapcar (lambda (att) 2077 :args (mapcar (lambda (att)
2087 (list 'group 2078 (list 'group
2088 :inline t 2079 :inline t
2089 :sibling-args (widget-get (nth 1 att) :sibling-args) 2080 :sibling-args (widget-get (nth 1 att) :sibling-args)
2090 (list 'const :format "" :value (nth 0 att)) 2081 (list 'const :format "" :value (nth 0 att))
2095 2086
2096 (define-widget 'custom-display 'menu-choice 2087 (define-widget 'custom-display 'menu-choice
2097 "Select a display type." 2088 "Select a display type."
2098 :tag "Display" 2089 :tag "Display"
2099 :value t 2090 :value t
2100 :help-echo "Specify frames where the face attributes should be used." 2091 :help-echo "Specify frames where the face attributes should be used"
2101 :args '((const :tag "all" t) 2092 :args '((const :tag "all" t)
2102 (checklist 2093 (checklist
2103 :offset 0 2094 :offset 0
2104 :extra-offset 9 2095 :extra-offset 9
2105 :args ((group :sibling-args (:help-echo "\ 2096 :args ((group :sibling-args (:help-echo "\
2106 Only match the specified window systems.") 2097 Only match the specified window systems")
2107 (const :format "Type: " 2098 (const :format "Type: "
2108 type) 2099 type)
2109 (checklist :inline t 2100 (checklist :inline t
2110 :offset 0 2101 :offset 0
2111 (const :format "X " 2102 (const :format "X "
2112 :sibling-args (:help-echo "\ 2103 :sibling-args (:help-echo "\
2113 The X11 Window System.") 2104 The X11 Window System")
2114 x) 2105 x)
2115 (const :format "PM " 2106 (const :format "PM "
2116 :sibling-args (:help-echo "\ 2107 :sibling-args (:help-echo "\
2117 OS/2 Presentation Manager.") 2108 OS/2 Presentation Manager")
2118 pm) 2109 pm)
2119 (const :format "Win32 " 2110 (const :format "Win32 "
2120 :sibling-args (:help-echo "\ 2111 :sibling-args (:help-echo "\
2121 Windows NT/95/97.") 2112 Windows NT/95/97")
2122 win32) 2113 win32)
2123 (const :format "DOS " 2114 (const :format "DOS "
2124 :sibling-args (:help-echo "\ 2115 :sibling-args (:help-echo "\
2125 Plain MS-DOS.") 2116 Plain MS-DOS")
2126 pc) 2117 pc)
2127 (const :format "TTY%n" 2118 (const :format "TTY%n"
2128 :sibling-args (:help-echo "\ 2119 :sibling-args (:help-echo "\
2129 Plain text terminals.") 2120 Plain text terminals")
2130 tty))) 2121 tty)))
2131 (group :sibling-args (:help-echo "\ 2122 (group :sibling-args (:help-echo "\
2132 Only match the frames with the specified color support.") 2123 Only match the frames with the specified color support")
2133 (const :format "Class: " 2124 (const :format "Class: "
2134 class) 2125 class)
2135 (checklist :inline t 2126 (checklist :inline t
2136 :offset 0 2127 :offset 0
2137 (const :format "Color " 2128 (const :format "Color "
2138 :sibling-args (:help-echo "\ 2129 :sibling-args (:help-echo "\
2139 Match color frames.") 2130 Match color frames")
2140 color) 2131 color)
2141 (const :format "Grayscale " 2132 (const :format "Grayscale "
2142 :sibling-args (:help-echo "\ 2133 :sibling-args (:help-echo "\
2143 Match grayscale frames.") 2134 Match grayscale frames")
2144 grayscale) 2135 grayscale)
2145 (const :format "Monochrome%n" 2136 (const :format "Monochrome%n"
2146 :sibling-args (:help-echo "\ 2137 :sibling-args (:help-echo "\
2147 Match frames with no color support.") 2138 Match frames with no color support")
2148 mono))) 2139 mono)))
2149 (group :sibling-args (:help-echo "\ 2140 (group :sibling-args (:help-echo "\
2150 Only match frames with the specified intensity.") 2141 Only match frames with the specified intensity")
2151 (const :format "\ 2142 (const :format "\
2152 Background brightness: " 2143 Background brightness: "
2153 background) 2144 background)
2154 (checklist :inline t 2145 (checklist :inline t
2155 :offset 0 2146 :offset 0
2156 (const :format "Light " 2147 (const :format "Light "
2157 :sibling-args (:help-echo "\ 2148 :sibling-args (:help-echo "\
2158 Match frames with light backgrounds.") 2149 Match frames with light backgrounds")
2159 light) 2150 light)
2160 (const :format "Dark\n" 2151 (const :format "Dark\n"
2161 :sibling-args (:help-echo "\ 2152 :sibling-args (:help-echo "\
2162 Match frames with dark backgrounds.") 2153 Match frames with dark backgrounds")
2163 dark))))))) 2154 dark)))))))
2164 2155
2165 ;;; The `custom-face' Widget. 2156 ;;; The `custom-face' Widget.
2166 2157
2167 (defface custom-face-tag-face '((t (:underline t))) 2158 (defface custom-face-tag-face '((t (:underline t)))
2169 :group 'custom-faces) 2160 :group 'custom-faces)
2170 2161
2171 (define-widget 'custom-face 'custom 2162 (define-widget 'custom-face 'custom
2172 "Customize face." 2163 "Customize face."
2173 :sample-face 'custom-face-tag-face 2164 :sample-face 'custom-face-tag-face
2174 :help-echo "Set or reset this face." 2165 :help-echo "Set or reset this face"
2175 :documentation-property '(lambda (face) 2166 :documentation-property '(lambda (face)
2176 (face-doc-string face)) 2167 (face-doc-string face))
2177 :value-create 'custom-face-value-create 2168 :value-create 'custom-face-value-create
2178 :action 'custom-face-action 2169 :action 'custom-face-action
2179 :custom-category 'face 2170 :custom-category 'face
2186 :custom-menu 'custom-face-menu-create) 2177 :custom-menu 'custom-face-menu-create)
2187 2178
2188 (define-widget 'custom-face-all 'editable-list 2179 (define-widget 'custom-face-all 'editable-list
2189 "An editable list of display specifications and attributes." 2180 "An editable list of display specifications and attributes."
2190 :entry-format "%i %d %v" 2181 :entry-format "%i %d %v"
2191 :insert-button-args '(:help-echo "Insert new display specification here.") 2182 :insert-button-args '(:help-echo "Insert new display specification here")
2192 :append-button-args '(:help-echo "Append new display specification here.") 2183 :append-button-args '(:help-echo "Append new display specification here")
2193 :delete-button-args '(:help-echo "Delete this display specification.") 2184 :delete-button-args '(:help-echo "Delete this display specification")
2194 :args '((group :format "%v" custom-display custom-face-edit))) 2185 :args '((group :format "%v" custom-display custom-face-edit)))
2195 2186
2196 (defconst custom-face-all (widget-convert 'custom-face-all) 2187 (defconst custom-face-all (widget-convert 'custom-face-all)
2197 "Converted version of the `custom-face-all' widget.") 2188 "Converted version of the `custom-face-all' widget.")
2198 2189
2241 (if (eq custom-buffer-style 'face) 2232 (if (eq custom-buffer-style 'face)
2242 (insert " ") 2233 (insert " ")
2243 (widget-specify-sample widget begin (point)) 2234 (widget-specify-sample widget begin (point))
2244 (insert ": ")) 2235 (insert ": "))
2245 ;; Sample. 2236 ;; Sample.
2246 (and (string-match "XEmacs" emacs-version) 2237 (and (not (find-face symbol))
2247 ;; XEmacs cannot display uninitialized faces. 2238 ;; XEmacs cannot display uninitialized faces.
2248 (not (custom-facep symbol))
2249 (copy-face 'custom-face-empty symbol)) 2239 (copy-face 'custom-face-empty symbol))
2250 (push (widget-create-child-and-convert widget 'item 2240 (push (widget-create-child-and-convert widget 'item
2251 :format "(%{%t%})" 2241 :format "(%{%t%})"
2252 :sample-face symbol 2242 :sample-face symbol
2253 :tag "sample") 2243 :tag "sample")
2254 buttons) 2244 buttons)
2255 ;; Visibility. 2245 ;; Visibility.
2256 (insert " ") 2246 (insert " ")
2257 (push (widget-create-child-and-convert 2247 (push (widget-create-child-and-convert
2258 widget 'visibility 2248 widget 'visibility
2259 :help-echo "Hide or show this face." 2249 :help-echo "Hide or show this face"
2260 :action 'custom-toggle-parent 2250 :action 'custom-toggle-parent
2261 (not (eq state 'hidden))) 2251 (not (eq state 'hidden)))
2262 buttons) 2252 buttons)
2263 ;; Magic. 2253 ;; Magic.
2264 (insert "\n") 2254 (insert "\n")
2442 :value-create 'widget-face-value-create 2432 :value-create 'widget-face-value-create
2443 :value-delete 'widget-face-value-delete 2433 :value-delete 'widget-face-value-delete
2444 :value-get 'widget-value-value-get 2434 :value-get 'widget-value-value-get
2445 :validate 'widget-children-validate 2435 :validate 'widget-children-validate
2446 :action 'widget-face-action 2436 :action 'widget-face-action
2447 :match '(lambda (widget value) (symbolp value))) 2437 :match (lambda (widget value) (symbolp value)))
2448 2438
2449 (defun widget-face-value-create (widget) 2439 (defun widget-face-value-create (widget)
2450 ;; Create a `custom-face' child. 2440 ;; Create a `custom-face' child.
2451 (let* ((symbol (widget-value widget)) 2441 (let* ((symbol (widget-value widget))
2452 (custom-buffer-style 'face) 2442 (custom-buffer-style 'face)
2512 2502
2513 ;;; The `custom-group-link' Widget. 2503 ;;; The `custom-group-link' Widget.
2514 2504
2515 (define-widget 'custom-group-link 'link 2505 (define-widget 'custom-group-link 'link
2516 "Show parent in other window when activated." 2506 "Show parent in other window when activated."
2517 :help-echo "Create customization buffer for this group." 2507 :help-echo 'custom-group-link-help-echo
2518 :action 'custom-group-link-action) 2508 :action 'custom-group-link-action)
2509
2510 (defun custom-group-link-help-echo (widget)
2511 (concat "Create customization buffer for the `"
2512 (custom-unlispify-tag-name (widget-value widget))
2513 "' group"))
2519 2514
2520 (defun custom-group-link-action (widget &rest ignore) 2515 (defun custom-group-link-action (widget &rest ignore)
2521 (customize-group (widget-value widget))) 2516 (customize-group (widget-value widget)))
2522 2517
2523 ;;; The `custom-group' Widget. 2518 ;;; The `custom-group' Widget.
2553 (define-widget 'custom-group 'custom 2548 (define-widget 'custom-group 'custom
2554 "Customize group." 2549 "Customize group."
2555 :format "%v" 2550 :format "%v"
2556 :sample-face-get 'custom-group-sample-face-get 2551 :sample-face-get 'custom-group-sample-face-get
2557 :documentation-property 'group-documentation 2552 :documentation-property 'group-documentation
2558 :help-echo "Set or reset all members of this group." 2553 :help-echo "Set or reset all members of this group"
2559 :value-create 'custom-group-value-create 2554 :value-create 'custom-group-value-create
2560 :action 'custom-group-action 2555 :action 'custom-group-action
2561 :custom-category 'group 2556 :custom-category 'group
2562 :custom-set 'custom-group-set 2557 :custom-set 'custom-group-set
2563 :custom-save 'custom-group-save 2558 :custom-save 'custom-group-save
2585 "Return SYMBOL's custom group members. 2580 "Return SYMBOL's custom group members.
2586 If GROUPS-ONLY non-nil, return only those members that are groups." 2581 If GROUPS-ONLY non-nil, return only those members that are groups."
2587 (if (not groups-only) 2582 (if (not groups-only)
2588 (get symbol 'custom-group) 2583 (get symbol 'custom-group)
2589 (let (members) 2584 (let (members)
2590 (dolist (entry (get symbol 'custom-group)) 2585 (dolist (entry (get symbol 'custom-group) (nreverse members))
2591 (when (eq (nth 1 entry) 'custom-group) 2586 (when (eq (nth 1 entry) 'custom-group)
2592 (push entry members))) 2587 (push entry members))))))
2593 (nreverse members))))
2594 2588
2595 (defun custom-group-value-create (widget) 2589 (defun custom-group-value-create (widget)
2596 "Insert a customize group for WIDGET in the current buffer." 2590 "Insert a customize group for WIDGET in the current buffer."
2597 (let* ((state (widget-get widget :custom-state)) 2591 (let* ((state (widget-get widget :custom-state))
2598 (level (widget-get widget :custom-level)) 2592 (level (widget-get widget :custom-level))
2696 (insert " group: ") 2690 (insert " group: ")
2697 ;; Create link/visibility indicator. 2691 ;; Create link/visibility indicator.
2698 (if (eq custom-buffer-style 'links) 2692 (if (eq custom-buffer-style 'links)
2699 (push (widget-create-child-and-convert 2693 (push (widget-create-child-and-convert
2700 widget 'custom-group-link 2694 widget 'custom-group-link
2701 :tag "Go to Group" 2695 :tag "Open"
2702 symbol) 2696 symbol)
2703 buttons) 2697 buttons)
2704 (push (widget-create-child-and-convert 2698 (push (widget-create-child-and-convert
2705 widget 'group-visibility 2699 widget 'custom-group-visibility
2706 :help-echo "Show members of this group." 2700 :help-echo "Show members of this group"
2707 :action 'custom-toggle-parent 2701 :action 'custom-toggle-parent
2708 (not (eq state 'hidden))) 2702 (not (eq state 'hidden)))
2709 buttons)) 2703 buttons))
2710 (insert " \n") 2704 (insert " \n")
2711 ;; Create magic button. 2705 ;; Create magic button.
2719 (if (and (eq custom-buffer-style 'links) (> level 1)) 2713 (if (and (eq custom-buffer-style 'links) (> level 1))
2720 (widget-put widget :documentation-indent 0)) 2714 (widget-put widget :documentation-indent 0))
2721 (widget-default-format-handler widget ?h)) 2715 (widget-default-format-handler widget ?h))
2722 ;; Nested style. 2716 ;; Nested style.
2723 (t ;Visible. 2717 (t ;Visible.
2718 (custom-load-widget widget)
2719 ;; Update members
2720 (setq members (custom-group-members
2721 symbol (and (eq custom-buffer-style 'tree)
2722 custom-browse-only-groups)))
2724 ;; Add parent groups references above the group. 2723 ;; Add parent groups references above the group.
2725 (if t ;;; This should test that the buffer 2724 (if t ;;; This should test that the buffer
2726 ;;; was made to display a group. 2725 ;;; was made to display a group.
2727 (when (eq level 1) 2726 (when (eq level 1)
2728 (if (custom-add-parent-links widget 2727 (if (custom-add-parent-links widget
2739 ;; Create visibility indicator. 2738 ;; Create visibility indicator.
2740 (unless (eq custom-buffer-style 'links) 2739 (unless (eq custom-buffer-style 'links)
2741 (insert "--------") 2740 (insert "--------")
2742 (push (widget-create-child-and-convert 2741 (push (widget-create-child-and-convert
2743 widget 'visibility 2742 widget 'visibility
2744 :help-echo "Hide members of this group." 2743 :help-echo "Hide members of this group"
2745 :action 'custom-toggle-parent 2744 :action 'custom-toggle-parent
2746 (not (eq state 'hidden))) 2745 (not (eq state 'hidden)))
2747 buttons) 2746 buttons)
2748 (insert " ")) 2747 (insert " "))
2749 ;; Create more dashes. 2748 ;; Create more dashes.
2772 (custom-add-see-also widget 2771 (custom-add-see-also widget
2773 (make-string (* custom-buffer-indent level) 2772 (make-string (* custom-buffer-indent level)
2774 ?\ )) 2773 ?\ ))
2775 ;; Members. 2774 ;; Members.
2776 (message "Creating group...") 2775 (message "Creating group...")
2777 (custom-load-widget widget)
2778 (let* ((members (custom-sort-items members 2776 (let* ((members (custom-sort-items members
2779 custom-buffer-sort-alphabetically 2777 custom-buffer-sort-alphabetically
2780 custom-buffer-order-groups)) 2778 custom-buffer-order-groups))
2781 (prefixes (widget-get widget :custom-prefixes)) 2779 (prefixes (widget-get widget :custom-prefixes))
2782 (custom-prefix-list (custom-prefix-add symbol prefixes)) 2780 (custom-prefix-list (custom-prefix-add symbol prefixes))
2783 (length (length members)) 2781 (length (length members))
2784 (count 0) 2782 (count 0)
2785 (children (mapcar (lambda (entry) 2783 (children (mapcar
2786 (widget-insert "\n") 2784 (lambda (entry)
2787 (message "\ 2785 (widget-insert "\n")
2786 (when (zerop (% count custom-skip-messages))
2787 (display-message
2788 'progress
2789 (format "\
2788 Creating group members... %2d%%" 2790 Creating group members... %2d%%"
2789 (/ (* 100.0 count) length)) 2791 (/ (* 100.0 count) length))))
2790 (setq count (1+ count)) 2792 (incf count)
2791 (prog1 2793 (prog1
2792 (widget-create-child-and-convert 2794 (widget-create-child-and-convert
2793 widget (nth 1 entry) 2795 widget (nth 1 entry)
2794 :group widget 2796 :group widget
2795 :tag (custom-unlispify-tag-name 2797 :tag (custom-unlispify-tag-name
2796 (nth 0 entry)) 2798 (nth 0 entry))
2797 :custom-prefixes custom-prefix-list 2799 :custom-prefixes custom-prefix-list
2798 :custom-level (1+ level) 2800 :custom-level (1+ level)
2799 :value (nth 0 entry)) 2801 :value (nth 0 entry))
2800 (unless (eq (preceding-char) ?\n) 2802 (unless (eq (preceding-char) ?\n)
2801 (widget-insert "\n")))) 2803 (widget-insert "\n"))))
2802 members))) 2804 members)))
2803 (message "Creating group magic...") 2805 (message "Creating group magic...")
2804 (mapcar 'custom-magic-reset children) 2806 (mapc 'custom-magic-reset children)
2805 (message "Creating group state...") 2807 (message "Creating group state...")
2806 (widget-put widget :children children) 2808 (widget-put widget :children children)
2807 (custom-group-state-update widget) 2809 (custom-group-state-update widget)
2808 (message "Creating group... done")) 2810 (message "Creating group... done"))
2809 ;; End line 2811 ;; End line
2852 (funcall answer widget))))) 2854 (funcall answer widget)))))
2853 2855
2854 (defun custom-group-set (widget) 2856 (defun custom-group-set (widget)
2855 "Set changes in all modified group members." 2857 "Set changes in all modified group members."
2856 (let ((children (widget-get widget :children))) 2858 (let ((children (widget-get widget :children)))
2857 (mapcar (lambda (child) 2859 (mapc (lambda (child)
2858 (when (eq (widget-get child :custom-state) 'modified) 2860 (when (eq (widget-get child :custom-state) 'modified)
2859 (widget-apply child :custom-set))) 2861 (widget-apply child :custom-set)))
2860 children ))) 2862 children)))
2861 2863
2862 (defun custom-group-save (widget) 2864 (defun custom-group-save (widget)
2863 "Save all modified group members." 2865 "Save all modified group members."
2864 (let ((children (widget-get widget :children))) 2866 (let ((children (widget-get widget :children)))
2865 (mapcar (lambda (child) 2867 (mapc (lambda (child)
2866 (when (memq (widget-get child :custom-state) '(modified set)) 2868 (when (memq (widget-get child :custom-state) '(modified set))
2867 (widget-apply child :custom-save))) 2869 (widget-apply child :custom-save)))
2868 children ))) 2870 children)))
2869 2871
2870 (defun custom-group-reset-current (widget) 2872 (defun custom-group-reset-current (widget)
2871 "Reset all modified group members." 2873 "Reset all modified group members."
2872 (let ((children (widget-get widget :children))) 2874 (let ((children (widget-get widget :children)))
2873 (mapcar (lambda (child) 2875 (mapc (lambda (child)
2874 (when (eq (widget-get child :custom-state) 'modified) 2876 (when (eq (widget-get child :custom-state) 'modified)
2875 (widget-apply child :custom-reset-current))) 2877 (widget-apply child :custom-reset-current)))
2876 children ))) 2878 children)))
2877 2879
2878 (defun custom-group-reset-saved (widget) 2880 (defun custom-group-reset-saved (widget)
2879 "Reset all modified or set group members." 2881 "Reset all modified or set group members."
2880 (let ((children (widget-get widget :children))) 2882 (let ((children (widget-get widget :children)))
2881 (mapcar (lambda (child) 2883 (mapc (lambda (child)
2882 (when (memq (widget-get child :custom-state) '(modified set)) 2884 (when (memq (widget-get child :custom-state) '(modified set))
2883 (widget-apply child :custom-reset-saved))) 2885 (widget-apply child :custom-reset-saved)))
2884 children ))) 2886 children)))
2885 2887
2886 (defun custom-group-reset-standard (widget) 2888 (defun custom-group-reset-standard (widget)
2887 "Reset all modified, set, or saved group members." 2889 "Reset all modified, set, or saved group members."
2888 (let ((children (widget-get widget :children))) 2890 (let ((children (widget-get widget :children)))
2889 (mapcar (lambda (child) 2891 (mapc (lambda (child)
2890 (when (memq (widget-get child :custom-state) 2892 (when (memq (widget-get child :custom-state)
2891 '(modified set saved)) 2893 '(modified set saved))
2892 (widget-apply child :custom-reset-standard))) 2894 (widget-apply child :custom-reset-standard)))
2893 children ))) 2895 children)))
2894 2896
2895 (defun custom-group-state-update (widget) 2897 (defun custom-group-state-update (widget)
2896 "Update magic." 2898 "Update magic."
2897 (unless (eq (widget-get widget :custom-state) 'hidden) 2899 (unless (eq (widget-get widget :custom-state) 'hidden)
2898 (let* ((children (widget-get widget :children)) 2900 (let* ((children (widget-get widget :children))
2988 ;; The default face must be first, since it affects the others. 2990 ;; The default face must be first, since it affects the others.
2989 (when value 2991 (when value
2990 (princ "\n '(default ") 2992 (princ "\n '(default ")
2991 (prin1 value) 2993 (prin1 value)
2992 (if (or (get 'default 'face-defface-spec) 2994 (if (or (get 'default 'face-defface-spec)
2993 (and (not (custom-facep 'default)) 2995 (and (not (find-face 'default))
2994 (not (get 'default 'force-face)))) 2996 (not (get 'default 'force-face))))
2995 (princ ")") 2997 (princ ")")
2996 (princ " t)")))) 2998 (princ " t)"))))
2997 (mapatoms (lambda (symbol) 2999 (mapatoms (lambda (symbol)
2998 (let ((value (get symbol 'saved-face))) 3000 (let ((value (get symbol 'saved-face)))
3002 (princ "\n '(") 3004 (princ "\n '(")
3003 (princ symbol) 3005 (princ symbol)
3004 (princ " ") 3006 (princ " ")
3005 (prin1 value) 3007 (prin1 value)
3006 (if (or (get symbol 'face-defface-spec) 3008 (if (or (get symbol 'face-defface-spec)
3007 (and (not (custom-facep symbol)) 3009 (and (not (find-face symbol))
3008 (not (get symbol 'force-face)))) 3010 (not (get symbol 'force-face))))
3009 (princ ")") 3011 (princ ")")
3010 (princ " t)")))))) 3012 (princ " t)"))))))
3011 (princ ")") 3013 (princ ")")
3012 (unless (looking-at "\n") 3014 (unless (looking-at "\n")
3032 (defun custom-save-all () 3034 (defun custom-save-all ()
3033 "Save all customizations in `custom-file'." 3035 "Save all customizations in `custom-file'."
3034 (let ((inhibit-read-only t)) 3036 (let ((inhibit-read-only t))
3035 (custom-save-variables) 3037 (custom-save-variables)
3036 (custom-save-faces) 3038 (custom-save-faces)
3037 (save-excursion 3039 (with-current-buffer (find-file-noselect custom-file)
3038 (set-buffer (find-file-noselect custom-file))
3039 (save-buffer)))) 3040 (save-buffer))))
3040 3041
3042
3041 ;;; The Customize Menu. 3043 ;;; The Customize Menu.
3042 3044
3043 ;;; Menu support 3045 ;;; Menu support
3044
3045 (defcustom custom-menu-nesting 2
3046 "Maximum nesting in custom menus."
3047 :type 'integer
3048 :group 'custom-menu)
3049 3046
3050 (defun custom-face-menu-create (widget symbol) 3047 (defun custom-face-menu-create (widget symbol)
3051 "Ignoring WIDGET, create a menu entry for customization face SYMBOL." 3048 "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
3052 (vector (custom-unlispify-menu-entry symbol) 3049 (vector (custom-unlispify-menu-entry symbol)
3053 `(customize-face ',symbol) 3050 `(customize-face ',symbol)
3070 (vector (custom-unlispify-menu-entry symbol) 3067 (vector (custom-unlispify-menu-entry symbol)
3071 `(customize-variable ',symbol) 3068 `(customize-variable ',symbol)
3072 ':style 'toggle 3069 ':style 'toggle
3073 ':selected symbol))) 3070 ':selected symbol)))
3074 3071
3075 (if (string-match "XEmacs" emacs-version) 3072 ;; XEmacs can create menus dynamically.
3076 ;; XEmacs can create menus dynamically. 3073 (defun custom-group-menu-create (widget symbol)
3077 (defun custom-group-menu-create (widget symbol) 3074 "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
3078 "Ignoring WIDGET, create a menu entry for customization group SYMBOL." 3075 `( ,(custom-unlispify-menu-entry symbol t)
3079 `( ,(custom-unlispify-menu-entry symbol t) 3076 :filter (lambda (&rest junk)
3080 :filter (lambda (&rest junk) 3077 (cdr (custom-menu-create ',symbol)))))
3081 (cdr (custom-menu-create ',symbol)))))
3082 ;; But emacs can't.
3083 (defun custom-group-menu-create (widget symbol)
3084 "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
3085 ;; Limit the nesting.
3086 (let ((custom-menu-nesting (1- custom-menu-nesting)))
3087 (custom-menu-create symbol))))
3088 3078
3089 ;;;###autoload 3079 ;;;###autoload
3090 (defun custom-menu-create (symbol) 3080 (defun custom-menu-create (symbol)
3091 "Create menu for customization group SYMBOL. 3081 "Create menu for customization group SYMBOL.
3092 The menu is in a format applicable to `easy-menu-define'." 3082 The menu is in a format applicable to `easy-menu-define'."
3093 (let* ((item (vector (custom-unlispify-menu-entry symbol) 3083 (let* ((item (vector (custom-unlispify-menu-entry symbol)
3094 `(customize-group ',symbol) 3084 `(customize-group ',symbol)
3095 t))) 3085 t)))
3096 ;; Item is the entry for creating a menu buffer for SYMBOL. 3086 ;; Item is the entry for creating a menu buffer for SYMBOL.
3097 (if (< custom-menu-nesting 0) 3087 ;; We may nest, if the menu is not too big.
3098 ;; We don't nest any further. 3088 (custom-load-symbol symbol)
3099 item 3089 (if (< (length (get symbol 'custom-group)) widget-menu-max-size)
3100 ;; We may nest, if the menu is not too big. 3090 ;; The menu is not too big.
3101 (custom-load-symbol symbol) 3091 (let ((custom-prefix-list (custom-prefix-add symbol
3102 (if (< (length (get symbol 'custom-group)) widget-menu-max-size) 3092 custom-prefix-list))
3103 ;; The menu is not too big. 3093 (members (custom-sort-items (get symbol 'custom-group)
3104 (let ((custom-prefix-list (custom-prefix-add symbol 3094 custom-menu-sort-alphabetically
3105 custom-prefix-list)) 3095 custom-menu-order-groups)))
3106 (members (custom-sort-items (get symbol 'custom-group) 3096 ;; Create the menu.
3107 custom-menu-sort-alphabetically 3097 `(,(custom-unlispify-menu-entry symbol t)
3108 custom-menu-order-groups))) 3098 ,item
3109 ;; Create the menu. 3099 "--"
3110 `(,(custom-unlispify-menu-entry symbol t) 3100 ,@(mapcar (lambda (entry)
3111 ,item 3101 (widget-apply (if (listp (nth 1 entry))
3112 "--" 3102 (nth 1 entry)
3113 ,@(mapcar (lambda (entry) 3103 (list (nth 1 entry)))
3114 (widget-apply (if (listp (nth 1 entry)) 3104 :custom-menu (nth 0 entry)))
3115 (nth 1 entry) 3105 members)))
3116 (list (nth 1 entry))) 3106 ;; The menu was too big.
3117 :custom-menu (nth 0 entry))) 3107 item)))
3118 members)))
3119 ;; The menu was too big.
3120 item))))
3121 3108
3122 ;;;###autoload 3109 ;;;###autoload
3123 (defun customize-menu-create (symbol &optional name) 3110 (defun customize-menu-create (symbol &optional name)
3124 "Return a customize menu for customization group SYMBOL. 3111 "Return a customize menu for customization group SYMBOL.
3125 If optional NAME is given, use that as the name of the menu. 3112 If optional NAME is given, use that as the name of the menu.
3126 Otherwise the menu will be named `Customize'. 3113 Otherwise the menu will be named `Customize'.
3127 The format is suitable for use with `easy-menu-define'." 3114 The format is suitable for use with `easy-menu-define'."
3128 (unless name 3115 (unless name
3129 (setq name "Customize")) 3116 (setq name "Customize"))
3130 (if (string-match "XEmacs" emacs-version) 3117 `(,name
3131 ;; We can delay it under XEmacs. 3118 :filter (lambda (&rest junk)
3132 `(,name 3119 (cdr (custom-menu-create ',symbol)))))
3133 :filter (lambda (&rest junk)
3134 (cdr (custom-menu-create ',symbol))))
3135 ;; But we must create it now under Emacs.
3136 (cons name (cdr (custom-menu-create symbol)))))
3137 3120
3138 ;;; The Custom Mode. 3121 ;;; The Custom Mode.
3139 3122
3140 (defvar custom-mode-map nil 3123 (defvar custom-mode-map nil
3141 "Keymap for `custom-mode'.") 3124 "Keymap for `custom-mode'.")
3142 3125
3143 (unless custom-mode-map 3126 (unless custom-mode-map
3144 (setq custom-mode-map (make-sparse-keymap)) 3127 (setq custom-mode-map (make-sparse-keymap))
3145 (set-keymap-parent custom-mode-map widget-keymap) 3128 (set-keymap-parents custom-mode-map widget-keymap)
3146 (suppress-keymap custom-mode-map) 3129 (suppress-keymap custom-mode-map)
3147 (define-key custom-mode-map " " 'scroll-up) 3130 (define-key custom-mode-map " " 'scroll-up)
3148 (define-key custom-mode-map "\177" 'scroll-down) 3131 (define-key custom-mode-map "\177" 'scroll-down)
3149 (define-key custom-mode-map "q" 'bury-buffer) 3132 (define-key custom-mode-map "q" 'bury-buffer)
3150 (define-key custom-mode-map "u" 'Custom-goto-parent) 3133 (define-key custom-mode-map "u" 'Custom-goto-parent)
3227 (setq widget-button-face 'custom-button-face) 3210 (setq widget-button-face 'custom-button-face)
3228 (make-local-hook 'widget-edit-functions) 3211 (make-local-hook 'widget-edit-functions)
3229 (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t) 3212 (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)
3230 (run-hooks 'custom-mode-hook)) 3213 (run-hooks 'custom-mode-hook))
3231 3214
3215
3232 ;;; The End. 3216 ;;; The End.
3233 3217
3234 (provide 'cus-edit) 3218 (provide 'cus-edit)
3235 3219
3236 ;; cus-edit.el ends here 3220 ;; cus-edit.el ends here