Mercurial > hg > xemacs-beta

comparison lisp/cus-edit.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 6719134a07c2
children de805c49cfc1
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
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, 2000 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 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
7 ;; Keywords: help, faces 7 ;; Keywords: help, faces
8 ;; Version: 1.9960-x 8 ;; Version: 1.9960-x
9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
10 10
11 ;; This file is part of XEmacs. 11 ;; This file is part of XEmacs.
397 "Convert symbol into a menu entry." 397 "Convert symbol into a menu entry."
398 (let ((custom-unlispify-menu-entries custom-unlispify-tag-names)) 398 (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
399 (custom-unlispify-menu-entry symbol t))) 399 (custom-unlispify-menu-entry symbol t)))
400 400
401 (defun custom-prefix-add (symbol prefixes) 401 (defun custom-prefix-add (symbol prefixes)
402 ;; Addd SYMBOL to list of ignored PREFIXES. 402 ;; Add SYMBOL to list of ignored PREFIXES.
403 (cons (or (get symbol 'custom-prefix) 403 (cons (or (get symbol 'custom-prefix)
404 (concat (symbol-name symbol) "-")) 404 (concat (symbol-name symbol) "-"))
405 prefixes)) 405 prefixes))
406 406
407 407
615 children))) 615 children)))
616 616
617 617
618 ;;; The Customize Commands 618 ;;; The Customize Commands
619 619
620 (defun custom-prompt-variable (prompt-var prompt-val) 620 (defun custom-prompt-variable (prompt-var prompt-val &optional comment)
621 "Prompt for a variable and a value and return them as a list. 621 "Prompt for a variable and a value and return them as a list.
622 PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the 622 PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the
623 prompt for the value. The %s escape in PROMPT-VAL is replaced with 623 prompt for the value. The %s escape in PROMPT-VAL is replaced with
624 the name of the variable. 624 the name of the variable.
625 625
626 If the variable has a `variable-interactive' property, that is used as if 626 If the variable has a `variable-interactive' property, that is used as if
627 it were the arg to `interactive' (which see) to interactively read the value. 627 it were the arg to `interactive' (which see) to interactively read the value.
628 628
629 If the variable has a `custom-type' property, it must be a widget and the 629 If the variable has a `custom-type' property, it must be a widget and the
630 `:prompt-value' property of that widget will be used for reading the value." 630 `:prompt-value' property of that widget will be used for reading the value.
631
632 If optional COMMENT argument is non nil, also prompt for a comment and return
633 it as the third element in the list."
631 (let* ((var (read-variable prompt-var)) 634 (let* ((var (read-variable prompt-var))
632 (minibuffer-help-form '(describe-variable var))) 635 (minibuffer-help-form '(describe-variable var))
633 (list var 636 (val
634 (let ((prop (get var 'variable-interactive)) 637 (let ((prop (get var 'variable-interactive))
635 (type (get var 'custom-type)) 638 (type (get var 'custom-type))
636 (prompt (format prompt-val var))) 639 (prompt (format prompt-val var)))
637 (unless (listp type) 640 (unless (listp type)
638 (setq type (list type))) 641 (setq type (list type)))
647 prompt 650 prompt
648 (if (boundp var) 651 (if (boundp var)
649 (symbol-value var)) 652 (symbol-value var))
650 (not (boundp var)))) 653 (not (boundp var))))
651 (t 654 (t
652 (eval-minibuffer prompt))))))) 655 (eval-minibuffer prompt))))))
656 (if comment
657 (list var val
658 (read-string "Comment: " (get var 'variable-comment)))
659 (list var val))
660 ))
653 661
654 ;;;###autoload 662 ;;;###autoload
655 (defun customize-set-value (var val) 663 (defun customize-set-value (var val &optional comment)
656 "Set VARIABLE to VALUE. VALUE is a Lisp object. 664 "Set VARIABLE to VALUE. VALUE is a Lisp object.
657 665
658 If VARIABLE has a `variable-interactive' property, that is used as if 666 If VARIABLE has a `variable-interactive' property, that is used as if
659 it were the arg to `interactive' (which see) to interactively read the value. 667 it were the arg to `interactive' (which see) to interactively read the value.
660 668
661 If VARIABLE has a `custom-type' property, it must be a widget and the 669 If VARIABLE has a `custom-type' property, it must be a widget and the
662 `:prompt-value' property of that widget will be used for reading the value." 670 `:prompt-value' property of that widget will be used for reading the value.
671
672 If given a prefix (or a COMMENT argument), also prompt for a comment."
663 (interactive (custom-prompt-variable "Set variable: " 673 (interactive (custom-prompt-variable "Set variable: "
664 "Set %s to value: ")) 674 "Set %s to value: "
665 675 current-prefix-arg))
666 (set var val)) 676
677 (set var val)
678 (cond ((string= comment "")
679 (put var 'variable-comment nil))
680 (comment
681 (put var 'variable-comment comment))))
667 682
668 ;;;###autoload 683 ;;;###autoload
669 (defun customize-set-variable (var val) 684 (defun customize-set-variable (var val &optional comment)
670 "Set the default for VARIABLE to VALUE. VALUE is a Lisp object. 685 "Set the default for VARIABLE to VALUE. VALUE is a Lisp object.
671 686
672 If VARIABLE has a `custom-set' property, that is used for setting 687 If VARIABLE has a `custom-set' property, that is used for setting
673 VARIABLE, otherwise `set-default' is used. 688 VARIABLE, otherwise `set-default' is used.
674 689
677 692
678 If VARIABLE has a `variable-interactive' property, that is used as if 693 If VARIABLE has a `variable-interactive' property, that is used as if
679 it were the arg to `interactive' (which see) to interactively read the value. 694 it were the arg to `interactive' (which see) to interactively read the value.
680 695
681 If VARIABLE has a `custom-type' property, it must be a widget and the 696 If VARIABLE has a `custom-type' property, it must be a widget and the
682 `:prompt-value' property of that widget will be used for reading the value. " 697 `:prompt-value' property of that widget will be used for reading the value.
698
699 If given a prefix (or a COMMENT argument), also prompt for a comment."
683 (interactive (custom-prompt-variable "Set variable: " 700 (interactive (custom-prompt-variable "Set variable: "
684 "Set customized value for %s to: ")) 701 "Set customized value for %s to: "
702 current-prefix-arg))
685 (funcall (or (get var 'custom-set) 'set-default) var val) 703 (funcall (or (get var 'custom-set) 'set-default) var val)
686 (put var 'customized-value (list (custom-quote val)))) 704 (put var 'customized-value (list (custom-quote val)))
705 (cond ((string= comment "")
706 (put var 'variable-comment nil)
707 (put var 'customized-variable-comment nil))
708 (comment
709 (put var 'variable-comment comment)
710 (put var 'customized-variable-comment comment))))
711
687 712
688 ;;;###autoload 713 ;;;###autoload
689 (defun customize-save-variable (var val) 714 (defun customize-save-variable (var val &optional comment)
690 "Set the default for VARIABLE to VALUE, and save it for future sessions. 715 "Set the default for VARIABLE to VALUE, and save it for future sessions.
691 If VARIABLE has a `custom-set' property, that is used for setting 716 If VARIABLE has a `custom-set' property, that is used for setting
692 VARIABLE, otherwise `set-default' is used. 717 VARIABLE, otherwise `set-default' is used.
693 718
694 The `customized-value' property of the VARIABLE will be set to a list 719 The `customized-value' property of the VARIABLE will be set to a list
696 721
697 If VARIABLE has a `variable-interactive' property, that is used as if 722 If VARIABLE has a `variable-interactive' property, that is used as if
698 it were the arg to `interactive' (which see) to interactively read the value. 723 it were the arg to `interactive' (which see) to interactively read the value.
699 724
700 If VARIABLE has a `custom-type' property, it must be a widget and the 725 If VARIABLE has a `custom-type' property, it must be a widget and the
701 `:prompt-value' property of that widget will be used for reading the value. " 726 `:prompt-value' property of that widget will be used for reading the value.
727
728 If given a prefix (or a COMMENT argument), also prompt for a comment."
702 (interactive (custom-prompt-variable "Set and ave variable: " 729 (interactive (custom-prompt-variable "Set and ave variable: "
703 "Set and save value for %s as: ")) 730 "Set and save value for %s as: "
731 current-prefix-arg))
704 (funcall (or (get var 'custom-set) 'set-default) var val) 732 (funcall (or (get var 'custom-set) 'set-default) var val)
705 (put var 'saved-value (list (custom-quote val))) 733 (put var 'saved-value (list (custom-quote val)))
734 (custom-push-theme 'theme-value var 'user 'set (list (custom-quote val)))
735 (cond ((string= comment "")
736 (put var 'variable-comment nil)
737 (put var 'saved-variable-comment nil))
738 (comment
739 (put var 'variable-comment comment)
740 (put var 'saved-variable-comment comment)))
706 (custom-save-all)) 741 (custom-save-all))
707 742
708 ;;;###autoload 743 ;;;###autoload
709 (defun customize (group) 744 (defun customize (group)
710 "Select a customization buffer which you can use to set user options. 745 "Select a customization buffer which you can use to set user options.
840 (defun customize-customized () 875 (defun customize-customized ()
841 "Customize all user options set since the last save in this session." 876 "Customize all user options set since the last save in this session."
842 (interactive) 877 (interactive)
843 (let ((found nil)) 878 (let ((found nil))
844 (mapatoms (lambda (symbol) 879 (mapatoms (lambda (symbol)
845 (and (get symbol 'customized-face) 880 (and (or (get symbol 'customized-face)
881 (get symbol 'customized-face-comment))
846 (find-face symbol) 882 (find-face symbol)
847 (push (list symbol 'custom-face) found)) 883 (push (list symbol 'custom-face) found))
848 (and (get symbol 'customized-value) 884 (and (or (get symbol 'customized-value)
885 (get symbol 'customized-variable-comment))
849 (boundp symbol) 886 (boundp symbol)
850 (push (list symbol 'custom-variable) found)))) 887 (push (list symbol 'custom-variable) found))))
851 (if (not found) 888 (if (not found)
852 (error "No customized user options") 889 (error "No customized user options")
853 (custom-buffer-create (custom-sort-items found t nil) 890 (custom-buffer-create (custom-sort-items found t nil)
857 (defun customize-saved () 894 (defun customize-saved ()
858 "Customize all already saved user options." 895 "Customize all already saved user options."
859 (interactive) 896 (interactive)
860 (let ((found nil)) 897 (let ((found nil))
861 (mapatoms (lambda (symbol) 898 (mapatoms (lambda (symbol)
862 (and (get symbol 'saved-face) 899 (and (or (get symbol 'saved-face)
900 (get symbol 'saved-face-comment))
863 (find-face symbol) 901 (find-face symbol)
864 (push (list symbol 'custom-face) found)) 902 (push (list symbol 'custom-face) found))
865 (and (get symbol 'saved-value) 903 (and (or (get symbol 'saved-value)
904 (get symbol 'saved-variable-comment))
866 (boundp symbol) 905 (boundp symbol)
867 (push (list symbol 'custom-variable) found)))) 906 (push (list symbol 'custom-variable) found))))
868 (if (not found ) 907 (if (not found )
869 (error "No saved user options") 908 (error "No saved user options")
870 (custom-buffer-create (custom-sort-items found t nil) 909 (custom-buffer-create (custom-sort-items found t nil)
992 (defun custom-buffer-create-buttons () 1031 (defun custom-buffer-create-buttons ()
993 (message "Creating customization buttons...") 1032 (message "Creating customization buttons...")
994 (widget-insert "\nOperate on everything in this buffer:\n ") 1033 (widget-insert "\nOperate on everything in this buffer:\n ")
995 (widget-create 'push-button 1034 (widget-create 'push-button
996 :tag "Set" 1035 :tag "Set"
997 :tag-glyph '("set-up" "set-down")
998 :help-echo "\ 1036 :help-echo "\
999 Make your editing in this buffer take effect for this session" 1037 Make your editing in this buffer take effect for this session"
1000 :action (lambda (widget &optional event) 1038 :action (lambda (widget &optional event)
1001 (Custom-set))) 1039 (Custom-set)))
1002 (widget-insert " ") 1040 (widget-insert " ")
1003 (widget-create 'push-button 1041 (widget-create 'push-button
1004 :tag "Save" 1042 :tag "Save"
1005 :tag-glyph '("save-up" "save-down")
1006 :help-echo "\ 1043 :help-echo "\
1007 Make your editing in this buffer take effect for future Emacs sessions" 1044 Make your editing in this buffer take effect for future Emacs sessions"
1008 :action (lambda (widget &optional event) 1045 :action (lambda (widget &optional event)
1009 (Custom-save))) 1046 (Custom-save)))
1010 (if custom-reset-button-menu 1047 (if custom-reset-button-menu
1036 Reset all values in this buffer to their standard settings" 1073 Reset all values in this buffer to their standard settings"
1037 :action 'Custom-reset-standard)) 1074 :action 'Custom-reset-standard))
1038 (widget-insert " ") 1075 (widget-insert " ")
1039 (widget-create 'push-button 1076 (widget-create 'push-button
1040 :tag "Done" 1077 :tag "Done"
1041 :tag-glyph '("done-up" "done-down")
1042 :help-echo "Remove the buffer" 1078 :help-echo "Remove the buffer"
1043 :action (lambda (widget &optional event) 1079 :action (lambda (widget &optional event)
1044 (Custom-buffer-done))) 1080 (Custom-buffer-done)))
1045 (widget-insert "\n")) 1081 (widget-insert "\n"))
1046 1082
1209 (" |-" "middle") 1245 (" |-" "middle")
1210 (" `-" "bottom"))) 1246 (" `-" "bottom")))
1211 1247
1212 (defun custom-browse-insert-prefix (prefix) 1248 (defun custom-browse-insert-prefix (prefix)
1213 "Insert PREFIX. On XEmacs convert it to line graphics." 1249 "Insert PREFIX. On XEmacs convert it to line graphics."
1214 ;; ### Unfinished. 1250 ;; #### Unfinished.
1215 (if nil ; (string-match "XEmacs" emacs-version) 1251 (if nil ; (string-match "XEmacs" emacs-version)
1216 (progn 1252 (progn
1217 (insert "*") 1253 (insert "*")
1218 (while (not (string-equal prefix "")) 1254 (while (not (string-equal prefix ""))
1219 (let ((entry (substring prefix 0 3))) 1255 (let ((entry (substring prefix 0 3)))
1702 (widget-put widget :buttons buttons) 1738 (widget-put widget :buttons buttons)
1703 (if found 1739 (if found
1704 (insert "\n") 1740 (insert "\n")
1705 (delete-region start (point))) 1741 (delete-region start (point)))
1706 found)) 1742 found))
1743
1744 ;;; The `custom-comment' Widget.
1745
1746 ;; like the editable field
1747 (defface custom-comment-face '((((class grayscale color)
1748 (background light))
1749 (:background "gray85"))
1750 (((class grayscale color)
1751 (background dark))
1752 (:background "dim gray"))
1753 (t
1754 (:italic t)))
1755 "Face used for comments on variables or faces"
1756 :group 'custom-faces)
1757
1758 ;; like font-lock-comment-face
1759 (defface custom-comment-tag-face
1760 '((((class color) (background dark)) (:foreground "gray80"))
1761 (((class color) (background light)) (:foreground "blue4"))
1762 (((class grayscale) (background light))
1763 (:foreground "DimGray" :bold t :italic t))
1764 (((class grayscale) (background dark))
1765 (:foreground "LightGray" :bold t :italic t))
1766 (t (:bold t)))
1767 "Face used for variables or faces comment tags"
1768 :group 'custom-faces)
1769
1770 (define-widget 'custom-comment 'string
1771 "User comment"
1772 :tag "Comment"
1773 :help-echo "Edit a comment here"
1774 :sample-face 'custom-comment-tag-face
1775 :value-face 'custom-comment-face
1776 :value-set 'custom-comment-value-set
1777 :create 'custom-comment-create
1778 :delete 'custom-comment-delete)
1779
1780 (defun custom-comment-create (widget)
1781 (let (ext)
1782 (widget-default-create widget)
1783 (widget-put widget :comment-extent
1784 (setq ext (make-extent (widget-get widget :from)
1785 (widget-get widget :to))))
1786 (set-extent-property ext 'start-open t)
1787 (when (equal (widget-get widget :value) "")
1788 (set-extent-property ext 'invisible t))
1789 ))
1790
1791 (defun custom-comment-delete (widget)
1792 (widget-default-delete widget)
1793 (delete-extent (widget-get widget :comment-extent)))
1794
1795 (defun custom-comment-value-set (widget value)
1796 (widget-default-value-set widget value)
1797 (if (equal value "")
1798 (set-extent-property (widget-get widget :comment-extent)
1799 'invisible t)
1800 (set-extent-property (widget-get widget :comment-extent)
1801 'invisible nil)))
1802
1803 ;; Those functions are for the menu. WIDGET is NOT the comment widget. It's
1804 ;; the global custom one
1805 (defun custom-comment-show (widget)
1806 (set-extent-property
1807 (widget-get (widget-get widget :comment-widget) :comment-extent)
1808 'invisible nil))
1809
1810 (defun custom-comment-invisible-p (widget)
1811 (extent-property
1812 (widget-get (widget-get widget :comment-widget) :comment-extent)
1813 'invisible))
1707 1814
1708 ;;; The `custom-variable' Widget. 1815 ;;; The `custom-variable' Widget.
1709 1816
1710 (defface custom-variable-tag-face '((((class color) 1817 (defface custom-variable-tag-face '((((class color)
1711 (background dark)) 1818 (background dark))
1868 widget type 1975 widget type
1869 :format value-format 1976 :format value-format
1870 :value value) 1977 :value value)
1871 children)))) 1978 children))))
1872 (unless (eq custom-buffer-style 'tree) 1979 (unless (eq custom-buffer-style 'tree)
1873 ;; Now update the state.
1874 (unless (eq (preceding-char) ?\n) 1980 (unless (eq (preceding-char) ?\n)
1875 (widget-insert "\n")) 1981 (widget-insert "\n"))
1876 (if (eq state 'hidden)
1877 (widget-put widget :custom-state state)
1878 (custom-variable-state-set widget))
1879 ;; Create the magic button. 1982 ;; Create the magic button.
1880 (let ((magic (widget-create-child-and-convert 1983 (let ((magic (widget-create-child-and-convert
1881 widget 'custom-magic nil))) 1984 widget 'custom-magic nil)))
1882 (widget-put widget :custom-magic magic) 1985 (widget-put widget :custom-magic magic)
1883 (push magic buttons)) 1986 (push magic buttons))
1884 ;; Update properties. 1987 ;; Insert documentation.
1988 ;; #### NOTE: this is ugly!!!! I need to do update the :buttons property
1989 ;; before the call to `widget-default-format-handler'. Otherwise, I
1990 ;; loose my current `buttons'. This function shouldn't be called like
1991 ;; this anyway. The doc string widget should be added like the others.
1992 ;; --dv
1993 (widget-put widget :buttons buttons)
1994 (widget-default-format-handler widget ?h)
1995 ;; The comment field
1996 (unless (eq state 'hidden)
1997 (let* ((comment (get symbol 'variable-comment))
1998 (comment-widget
1999 (widget-create-child-and-convert
2000 widget 'custom-comment
2001 :parent widget
2002 :value (or comment ""))))
2003 (widget-put widget :comment-widget comment-widget)
2004 ;; Don't push it !!! Custom assumes that the first child is the
2005 ;; value one.
2006 (setq children (append children (list comment-widget)))))
2007 ;; Update the rest of the properties properties.
1885 (widget-put widget :custom-form form) 2008 (widget-put widget :custom-form form)
1886 (widget-put widget :buttons buttons)
1887 (widget-put widget :children children) 2009 (widget-put widget :children children)
1888 ;; Insert documentation. 2010 ;; Now update the state.
1889 (widget-default-format-handler widget ?h) 2011 (if (eq state 'hidden)
2012 (widget-put widget :custom-state state)
2013 (custom-variable-state-set widget))
1890 ;; See also. 2014 ;; See also.
1891 (unless (eq state 'hidden) 2015 (unless (eq state 'hidden)
1892 (when (eq (widget-get widget :custom-level) 1) 2016 (when (eq (widget-get widget :custom-level) 1)
1893 (custom-add-parent-links widget)) 2017 (custom-add-parent-links widget))
1894 (custom-add-see-also widget))))) 2018 (custom-add-see-also widget)))))
1908 (let* ((symbol (widget-value widget)) 2032 (let* ((symbol (widget-value widget))
1909 (get (or (get symbol 'custom-get) 'default-value)) 2033 (get (or (get symbol 'custom-get) 'default-value))
1910 (value (if (default-boundp symbol) 2034 (value (if (default-boundp symbol)
1911 (funcall get symbol) 2035 (funcall get symbol)
1912 (widget-get widget :value))) 2036 (widget-get widget :value)))
2037 (comment (get symbol 'variable-comment))
1913 tmp 2038 tmp
1914 (state (cond ((setq tmp (get symbol 'customized-value)) 2039 temp
2040 (state (cond ((progn (setq tmp (get symbol 'customized-value))
2041 (setq temp
2042 (get symbol 'customized-variable-comment))
2043 (or tmp temp))
1915 (if (condition-case nil 2044 (if (condition-case nil
1916 (equal value (eval (car tmp))) 2045 (and (equal value (eval (car tmp)))
2046 (equal comment temp))
1917 (error nil)) 2047 (error nil))
1918 'set 2048 'set
1919 'changed)) 2049 'changed))
1920 ((setq tmp (get symbol 'saved-value)) 2050 ((progn (setq tmp (get symbol 'saved-value))
2051 (setq temp (get symbol 'saved-variable-comment))
2052 (or tmp temp))
1921 (if (condition-case nil 2053 (if (condition-case nil
1922 (equal value (eval (car tmp))) 2054 (and (equal value (eval (car tmp)))
2055 (equal comment temp))
1923 (error nil)) 2056 (error nil))
1924 'saved 2057 'saved
1925 'changed)) 2058 'changed))
1926 ((setq tmp (get symbol 'standard-value)) 2059 ((setq tmp (get symbol 'standard-value))
1927 (if (condition-case nil 2060 (if (condition-case nil
1928 (equal value (eval (car tmp))) 2061 (and (equal value (eval (car tmp)))
2062 (equal comment nil))
1929 (error nil)) 2063 (error nil))
1930 'standard 2064 'standard
1931 'changed)) 2065 'changed))
1932 (t 'rogue)))) 2066 (t 'rogue))))
1933 (widget-put widget :custom-state state))) 2067 (widget-put widget :custom-state state)))
1943 (lambda (widget) 2077 (lambda (widget)
1944 (and (default-boundp (widget-value widget)) 2078 (and (default-boundp (widget-value widget))
1945 (memq (widget-get widget :custom-state) '(modified changed))))) 2079 (memq (widget-get widget :custom-state) '(modified changed)))))
1946 ("Reset to Saved" custom-variable-reset-saved 2080 ("Reset to Saved" custom-variable-reset-saved
1947 (lambda (widget) 2081 (lambda (widget)
1948 (and (get (widget-value widget) 'saved-value) 2082 (and (or (get (widget-value widget) 'saved-value)
2083 (get (widget-value widget) 'saved-variable-comment))
1949 (memq (widget-get widget :custom-state) 2084 (memq (widget-get widget :custom-state)
1950 '(modified set changed rogue))))) 2085 '(modified set changed rogue)))))
1951 ("Reset to Standard Settings" custom-variable-reset-standard 2086 ("Reset to Standard Settings" custom-variable-reset-standard
1952 (lambda (widget) 2087 (lambda (widget)
1953 (and (get (widget-value widget) 'standard-value) 2088 (and (get (widget-value widget) 'standard-value)
1954 (memq (widget-get widget :custom-state) 2089 (memq (widget-get widget :custom-state)
1955 '(modified set changed saved rogue))))) 2090 '(modified set changed saved rogue)))))
2091 ("---" ignore ignore)
2092 ("Add Comment" custom-comment-show custom-comment-invisible-p)
1956 ("---" ignore ignore) 2093 ("---" ignore ignore)
1957 ("Don't show as Lisp expression" custom-variable-edit 2094 ("Don't show as Lisp expression" custom-variable-edit
1958 (lambda (widget) 2095 (lambda (widget)
1959 (eq (widget-get widget :custom-form) 'lisp))) 2096 (eq (widget-get widget :custom-form) 'lisp)))
1960 ("Show as Lisp expression" custom-variable-edit-lisp 2097 ("Show as Lisp expression" custom-variable-edit-lisp
2003 (let* ((form (widget-get widget :custom-form)) 2140 (let* ((form (widget-get widget :custom-form))
2004 (state (widget-get widget :custom-state)) 2141 (state (widget-get widget :custom-state))
2005 (child (car (widget-get widget :children))) 2142 (child (car (widget-get widget :children)))
2006 (symbol (widget-value widget)) 2143 (symbol (widget-value widget))
2007 (set (or (get symbol 'custom-set) 'set-default)) 2144 (set (or (get symbol 'custom-set) 'set-default))
2008 val) 2145 (comment-widget (widget-get widget :comment-widget))
2146 (comment (widget-value comment-widget))
2147 val)
2009 (cond ((eq state 'hidden) 2148 (cond ((eq state 'hidden)
2010 (error "Cannot set hidden variable")) 2149 (error "Cannot set hidden variable"))
2011 ((setq val (widget-apply child :validate)) 2150 ((setq val (widget-apply child :validate))
2012 (goto-char (widget-get val :from)) 2151 (goto-char (widget-get val :from))
2013 (error "%s" (widget-get val :error))) 2152 (error "%s" (widget-get val :error)))
2014 ((memq form '(lisp mismatch)) 2153 ((memq form '(lisp mismatch))
2154 (when (equal comment "")
2155 (setq comment nil)
2156 ;; Make the comment invisible by hand if it's empty
2157 (set-extent-property (widget-get comment-widget :comment-extent)
2158 'invisible t))
2015 (funcall set symbol (eval (setq val (widget-value child)))) 2159 (funcall set symbol (eval (setq val (widget-value child))))
2016 (put symbol 'customized-value (list val))) 2160 (put symbol 'customized-value (list val))
2161 (put symbol 'variable-comment comment)
2162 (put symbol 'customized-variable-comment comment))
2017 (t 2163 (t
2164 (when (equal comment "")
2165 (setq comment nil)
2166 ;; Make the comment invisible by hand if it's empty
2167 (set-extent-property (widget-get comment-widget :comment-extent)
2168 'invisible t))
2018 (funcall set symbol (setq val (widget-value child))) 2169 (funcall set symbol (setq val (widget-value child)))
2019 (put symbol 'customized-value (list (custom-quote val))))) 2170 (put symbol 'customized-value (list (custom-quote val)))
2171 (put symbol 'variable-comment comment)
2172 (put symbol 'customized-variable-comment comment)))
2020 (custom-variable-state-set widget) 2173 (custom-variable-state-set widget)
2021 (custom-redraw-magic widget))) 2174 (custom-redraw-magic widget)))
2022 2175
2023 (defun custom-variable-save (widget) 2176 (defun custom-variable-save (widget)
2024 "Set and save the value for the variable being edited by WIDGET." 2177 "Set and save the value for the variable being edited by WIDGET."
2025 (let* ((form (widget-get widget :custom-form)) 2178 (let* ((form (widget-get widget :custom-form))
2026 (state (widget-get widget :custom-state)) 2179 (state (widget-get widget :custom-state))
2027 (child (car (widget-get widget :children))) 2180 (child (car (widget-get widget :children)))
2028 (symbol (widget-value widget)) 2181 (symbol (widget-value widget))
2029 (set (or (get symbol 'custom-set) 'set-default)) 2182 (set (or (get symbol 'custom-set) 'set-default))
2183 (comment-widget (widget-get widget :comment-widget))
2184 (comment (widget-value comment-widget))
2030 val) 2185 val)
2031 (cond ((eq state 'hidden) 2186 (cond ((eq state 'hidden)
2032 (error "Cannot set hidden variable")) 2187 (error "Cannot set hidden variable"))
2033 ((setq val (widget-apply child :validate)) 2188 ((setq val (widget-apply child :validate))
2034 (goto-char (widget-get val :from)) 2189 (goto-char (widget-get val :from))
2035 (error "%s" (widget-get val :error))) 2190 (error "%s" (widget-get val :error)))
2036 ((memq form '(lisp mismatch)) 2191 ((memq form '(lisp mismatch))
2192 (when (equal comment "")
2193 (setq comment nil)
2194 ;; Make the comment invisible by hand if it's empty
2195 (set-extent-property (widget-get comment-widget :comment-extent)
2196 'invisible t))
2037 (put symbol 'saved-value (list (widget-value child))) 2197 (put symbol 'saved-value (list (widget-value child)))
2038 (funcall set symbol (eval (widget-value child)))) 2198 (custom-push-theme 'theme-value symbol 'user
2199 'set (list (widget-value child)))
2200 (funcall set symbol (eval (widget-value child)))
2201 (put symbol 'variable-comment comment)
2202 (put symbol 'saved-variable-comment comment))
2039 (t 2203 (t
2204 (when (equal comment "")
2205 (setq comment nil)
2206 ;; Make the comment invisible by hand if it's empty
2207 (set-extent-property (widget-get comment-widget :comment-extent)
2208 'invisible t))
2040 (put symbol 2209 (put symbol
2041 'saved-value (list (custom-quote (widget-value 2210 'saved-value (list (custom-quote (widget-value
2042 child)))) 2211 child))))
2043 (funcall set symbol (widget-value child)))) 2212 (custom-push-theme 'theme-value symbol 'user
2213 'set (list (custom-quote (widget-value
2214 child))))
2215 (funcall set symbol (widget-value child))
2216 (put symbol 'variable-comment comment)
2217 (put symbol 'saved-variable-comment comment)))
2044 (put symbol 'customized-value nil) 2218 (put symbol 'customized-value nil)
2219 (put symbol 'customized-variable-comment nil)
2045 (custom-save-all) 2220 (custom-save-all)
2046 (custom-variable-state-set widget) 2221 (custom-variable-state-set widget)
2047 (custom-redraw-magic widget))) 2222 (custom-redraw-magic widget)))
2048 2223
2049 (defun custom-variable-reset-saved (widget) 2224 (defun custom-variable-reset-saved (widget)
2050 "Restore the saved value for the variable being edited by WIDGET." 2225 "Restore the saved value for the variable being edited by WIDGET."
2051 (let* ((symbol (widget-value widget)) 2226 (let* ((symbol (widget-value widget))
2052 (set (or (get symbol 'custom-set) 'set-default))) 2227 (set (or (get symbol 'custom-set) 'set-default))
2053 (if (get symbol 'saved-value) 2228 (comment-widget (widget-get widget :comment-widget))
2054 (condition-case nil 2229 (value (get symbol 'saved-value))
2055 (funcall set symbol (eval (car (get symbol 'saved-value)))) 2230 (comment (get symbol 'saved-variable-comment)))
2056 (error nil)) 2231 (cond ((or value comment)
2057 (signal 'error (list "No saved value for variable" symbol))) 2232 (put symbol 'variable-comment comment)
2233 (condition-case nil
2234 (funcall set symbol (eval (car value)))
2235 (error nil)))
2236 (t
2237 (signal 'error (list "No saved value for variable" symbol))))
2058 (put symbol 'customized-value nil) 2238 (put symbol 'customized-value nil)
2239 (put symbol 'customized-variable-comment nil)
2059 (widget-put widget :custom-state 'unknown) 2240 (widget-put widget :custom-state 'unknown)
2241 ;; This call will possibly make the comment invisible
2060 (custom-redraw widget))) 2242 (custom-redraw widget)))
2061 2243
2062 (defun custom-variable-reset-standard (widget) 2244 (defun custom-variable-reset-standard (widget)
2063 "Restore the standard setting for the variable being edited by WIDGET." 2245 "Restore the standard setting for the variable being edited by WIDGET."
2064 (let* ((symbol (widget-value widget)) 2246 (let* ((symbol (widget-value widget))
2065 (set (or (get symbol 'custom-set) 'set-default))) 2247 (set (or (get symbol 'custom-set) 'set-default))
2248 (comment-widget (widget-get widget :comment-widget)))
2066 (if (get symbol 'standard-value) 2249 (if (get symbol 'standard-value)
2067 (funcall set symbol (eval (car (get symbol 'standard-value)))) 2250 (funcall set symbol (eval (car (get symbol 'standard-value))))
2068 (signal 'error (list "No standard setting known for variable" symbol))) 2251 (signal 'error (list "No standard setting known for variable" symbol)))
2252 (put symbol 'variable-comment nil)
2069 (put symbol 'customized-value nil) 2253 (put symbol 'customized-value nil)
2070 (when (get symbol 'saved-value) 2254 (put symbol 'customized-variable-comment nil)
2255 (when (or (get symbol 'saved-value) (get symbol 'saved-variable-comment))
2071 (put symbol 'saved-value nil) 2256 (put symbol 'saved-value nil)
2257 (custom-push-theme 'theme-value symbol 'user 'reset 'standard)
2258 ;; As a special optimizations we do not (explictly)
2259 ;; save resets to standard when no theme set the value.
2260 (if (null (cdr (get symbol 'theme-value)))
2261 (put symbol 'theme-value nil))
2262 (put symbol 'saved-variable-comment nil)
2072 (custom-save-all)) 2263 (custom-save-all))
2073 (widget-put widget :custom-state 'unknown) 2264 (widget-put widget :custom-state 'unknown)
2265 ;; This call will possibly make the comment invisible
2074 (custom-redraw widget))) 2266 (custom-redraw widget)))
2075 2267
2076 ;;; The `custom-face-edit' Widget. 2268 ;;; The `custom-face-edit' Widget.
2077 2269
2078 (define-widget 'custom-face-edit 'checklist 2270 (define-widget 'custom-face-edit 'checklist
2079 "Edit face attributes." 2271 "Edit face attributes."
2080 :format "%t: %v" 2272 :format "%t: %v"
2081 :tag "Attributes" 2273 :tag "Attributes"
2082 :extra-offset 12 2274 :extra-offset 12
2083 :button-args '(:help-echo "Control whether this attribute have any effect") 2275 :button-args '(:help-echo "Control whether this attribute has any effect")
2084 :args (mapcar (lambda (att) 2276 :args (mapcar (lambda (att)
2085 (list 'group 2277 (list 'group
2086 :inline t 2278 :inline t
2087 :sibling-args (widget-get (nth 1 att) :sibling-args) 2279 :sibling-args (widget-get (nth 1 att) :sibling-args)
2088 (list 'const :format "" :value (nth 0 att)) 2280 (list 'const :format "" :value (nth 0 att))
2114 :sibling-args (:help-echo "\ 2306 :sibling-args (:help-echo "\
2115 OS/2 Presentation Manager") 2307 OS/2 Presentation Manager")
2116 pm) 2308 pm)
2117 (const :format "MSWindows " 2309 (const :format "MSWindows "
2118 :sibling-args (:help-echo "\ 2310 :sibling-args (:help-echo "\
2119 Windows NT/95/97") 2311 Microsoft Windows, displays")
2120 mswindows) 2312 mswindows)
2121 (const :format "DOS " 2313 (const :format "MSPrinter "
2122 :sibling-args (:help-echo "\ 2314 :sibling-args (:help-echo "\
2123 Plain MS-DOS") 2315 Microsoft Windows, printers")
2124 pc) 2316 msprinter)
2125 (const :format "TTY%n" 2317 (const :format "TTY%n"
2126 :sibling-args (:help-echo "\ 2318 :sibling-args (:help-echo "\
2127 Plain text terminals") 2319 Plain text terminals")
2128 tty))) 2320 tty)))
2129 (group :sibling-args (:help-echo "\ 2321 (group :sibling-args (:help-echo "\
2322 Only match display or printer devices")
2323 (const :format "Output: "
2324 class)
2325 (checklist :inline t
2326 :offset 0
2327 (const :format "Display "
2328 :sibling-args (:help-echo "\
2329 Match display devices")
2330 display)
2331 (const :format "Printer%n"
2332 :sibling-args (:help-echo "\
2333 Match printer devices")
2334 printer)))
2335 (group :sibling-args (:help-echo "\
2130 Only match the frames with the specified color support") 2336 Only match the frames with the specified color support")
2131 (const :format "Class: " 2337 (const :format "Color support: "
2132 class) 2338 class)
2133 (checklist :inline t 2339 (checklist :inline t
2134 :offset 0 2340 :offset 0
2135 (const :format "Color " 2341 (const :format "Color "
2136 :sibling-args (:help-echo "\ 2342 :sibling-args (:help-echo "\
2223 "Converted version of the `custom-face-selected' widget.") 2429 "Converted version of the `custom-face-selected' widget.")
2224 2430
2225 (defun custom-face-value-create (widget) 2431 (defun custom-face-value-create (widget)
2226 "Create a list of the display specifications for WIDGET." 2432 "Create a list of the display specifications for WIDGET."
2227 (let ((buttons (widget-get widget :buttons)) 2433 (let ((buttons (widget-get widget :buttons))
2434 children
2228 (symbol (widget-get widget :value)) 2435 (symbol (widget-get widget :value))
2229 (tag (widget-get widget :tag)) 2436 (tag (widget-get widget :tag))
2230 (state (widget-get widget :custom-state)) 2437 (state (widget-get widget :custom-state))
2231 (begin (point)) 2438 (begin (point))
2232 (is-last (widget-get widget :custom-last)) 2439 (is-last (widget-get widget :custom-last))
2272 (push magic buttons)) 2479 (push magic buttons))
2273 ;; Update buttons. 2480 ;; Update buttons.
2274 (widget-put widget :buttons buttons) 2481 (widget-put widget :buttons buttons)
2275 ;; Insert documentation. 2482 ;; Insert documentation.
2276 (widget-default-format-handler widget ?h) 2483 (widget-default-format-handler widget ?h)
2484 ;; The comment field
2485 (unless (eq state 'hidden)
2486 (let* ((comment (get symbol 'face-comment))
2487 (comment-widget
2488 (widget-create-child-and-convert
2489 widget 'custom-comment
2490 :parent widget
2491 :value (or comment ""))))
2492 (widget-put widget :comment-widget comment-widget)
2493 (push comment-widget children)))
2277 ;; See also. 2494 ;; See also.
2278 (unless (eq state 'hidden) 2495 (unless (eq state 'hidden)
2279 (when (eq (widget-get widget :custom-level) 1) 2496 (when (eq (widget-get widget :custom-level) 1)
2280 (custom-add-parent-links widget)) 2497 (custom-add-parent-links widget))
2281 (custom-add-see-also widget)) 2498 (custom-add-see-also widget))
2286 (message "Creating face editor...") 2503 (message "Creating face editor...")
2287 (custom-load-widget widget) 2504 (custom-load-widget widget)
2288 (unless (widget-get widget :custom-form) 2505 (unless (widget-get widget :custom-form)
2289 (widget-put widget :custom-form custom-face-default-form)) 2506 (widget-put widget :custom-form custom-face-default-form))
2290 (let* ((symbol (widget-value widget)) 2507 (let* ((symbol (widget-value widget))
2291 (spec (or (get symbol 'customized-face) 2508 (spec (custom-face-get-spec symbol))
2292 (get symbol 'saved-face)
2293 (get symbol 'face-defface-spec)
2294 ;; Attempt to construct it.
2295 (list (list t (face-custom-attributes-get
2296 symbol (selected-frame))))))
2297 (form (widget-get widget :custom-form)) 2509 (form (widget-get widget :custom-form))
2298 (indent (widget-get widget :indent)) 2510 (indent (widget-get widget :indent))
2299 (edit (widget-create-child-and-convert 2511 (edit (widget-create-child-and-convert
2300 widget 2512 widget
2301 (cond ((and (eq form 'selected) 2513 (cond ((and (eq form 'selected)
2310 (t 2522 (t
2311 (when indent (insert-char ?\ indent)) 2523 (when indent (insert-char ?\ indent))
2312 'sexp)) 2524 'sexp))
2313 :value spec))) 2525 :value spec)))
2314 (custom-face-state-set widget) 2526 (custom-face-state-set widget)
2315 (widget-put widget :children (list edit))) 2527 (push edit children)
2528 (widget-put widget :children children))
2316 (message "Creating face editor...done")))))) 2529 (message "Creating face editor...done"))))))
2317 2530
2318 (defvar custom-face-menu 2531 (defvar custom-face-menu
2319 '(("Set for Current Session" custom-face-set) 2532 '(("Set for Current Session" custom-face-set)
2320 ("Save for Future Sessions" custom-face-save) 2533 ("Save for Future Sessions" custom-face-save)
2321 ("Reset to Saved" custom-face-reset-saved 2534 ("Reset to Saved" custom-face-reset-saved
2322 (lambda (widget) 2535 (lambda (widget)
2323 (get (widget-value widget) 'saved-face))) 2536 (or (get (widget-value widget) 'saved-face)
2537 (get (widget-value widget) 'saved-face-comment))))
2324 ("Reset to Standard Setting" custom-face-reset-standard 2538 ("Reset to Standard Setting" custom-face-reset-standard
2325 (lambda (widget) 2539 (lambda (widget)
2326 (get (widget-value widget) 'face-defface-spec))) 2540 (get (widget-value widget) 'face-defface-spec)))
2541 ("---" ignore ignore)
2542 ("Add Comment" custom-comment-show custom-comment-invisible-p)
2327 ("---" ignore ignore) 2543 ("---" ignore ignore)
2328 ("Show all display specs" custom-face-edit-all 2544 ("Show all display specs" custom-face-edit-all
2329 (lambda (widget) 2545 (lambda (widget)
2330 (not (eq (widget-get widget :custom-form) 'all)))) 2546 (not (eq (widget-get widget :custom-form) 'all))))
2331 ("Just current attributes" custom-face-edit-selected 2547 ("Just current attributes" custom-face-edit-selected
2359 (widget-put widget :custom-form 'lisp) 2575 (widget-put widget :custom-form 'lisp)
2360 (custom-redraw widget)) 2576 (custom-redraw widget))
2361 2577
2362 (defun custom-face-state-set (widget) 2578 (defun custom-face-state-set (widget)
2363 "Set the state of WIDGET." 2579 "Set the state of WIDGET."
2364 (let ((symbol (widget-value widget))) 2580 (let* ((symbol (widget-value widget))
2365 (widget-put widget :custom-state (cond ((get symbol 'customized-face) 2581 (comment (get symbol 'face-comment))
2366 'set) 2582 tmp temp)
2367 ((get symbol 'saved-face) 2583 (widget-put widget :custom-state
2368 'saved) 2584 (cond ((progn
2369 ((get symbol 'face-defface-spec) 2585 (setq tmp (get symbol 'customized-face))
2370 'standard) 2586 (setq temp (get symbol 'customized-face-comment))
2371 (t 2587 (or tmp temp))
2372 'rogue))))) 2588 (if (equal temp comment)
2589 'set
2590 'changed))
2591 ((progn
2592 (setq tmp (get symbol 'saved-face))
2593 (setq temp (get symbol 'saved-face-comment))
2594 (or tmp temp))
2595 (if (equal temp comment)
2596 'saved
2597 'changed))
2598 ((get symbol 'face-defface-spec)
2599 (if (equal comment nil)
2600 'standard
2601 'changed))
2602 (t
2603 'rogue)))))
2373 2604
2374 (defun custom-face-action (widget &optional event) 2605 (defun custom-face-action (widget &optional event)
2375 "Show the menu for `custom-face' WIDGET. 2606 "Show the menu for `custom-face' WIDGET.
2376 Optional EVENT is the location for the menu." 2607 Optional EVENT is the location for the menu."
2377 (if (eq (widget-get widget :custom-state) 'hidden) 2608 (if (eq (widget-get widget :custom-state) 'hidden)
2388 2619
2389 (defun custom-face-set (widget) 2620 (defun custom-face-set (widget)
2390 "Make the face attributes in WIDGET take effect." 2621 "Make the face attributes in WIDGET take effect."
2391 (let* ((symbol (widget-value widget)) 2622 (let* ((symbol (widget-value widget))
2392 (child (car (widget-get widget :children))) 2623 (child (car (widget-get widget :children)))
2393 (value (widget-value child))) 2624 (value (widget-value child))
2625 (comment-widget (widget-get widget :comment-widget))
2626 (comment (widget-value comment-widget)))
2627 (when (equal comment "")
2628 (setq comment nil)
2629 ;; Make the comment invisible by hand if it's empty
2630 (set-extent-property (widget-get comment-widget :comment-extent)
2631 'invisible t))
2394 (put symbol 'customized-face value) 2632 (put symbol 'customized-face value)
2395 (face-spec-set symbol value) 2633 (face-spec-set symbol value nil '(custom))
2634 (put symbol 'customized-face-comment comment)
2635 (put symbol 'face-comment comment)
2396 (custom-face-state-set widget) 2636 (custom-face-state-set widget)
2397 (custom-redraw-magic widget))) 2637 (custom-redraw-magic widget)))
2398 2638
2399 (defun custom-face-save (widget) 2639 (defun custom-face-save (widget)
2400 "Make the face attributes in WIDGET default." 2640 "Make the face attributes in WIDGET default."
2401 (let* ((symbol (widget-value widget)) 2641 (let* ((symbol (widget-value widget))
2402 (child (car (widget-get widget :children))) 2642 (child (car (widget-get widget :children)))
2403 (value (widget-value child))) 2643 (value (widget-value child))
2404 (face-spec-set symbol value) 2644 (comment-widget (widget-get widget :comment-widget))
2645 (comment (widget-value comment-widget)))
2646 (when (equal comment "")
2647 (setq comment nil)
2648 ;; Make the comment invisible by hand if it's empty
2649 (set-extent-property (widget-get comment-widget :comment-extent)
2650 'invisible t))
2651 (face-spec-set symbol value nil '(custom))
2405 (put symbol 'saved-face value) 2652 (put symbol 'saved-face value)
2653 (custom-push-theme 'theme-face symbol 'user 'set value)
2406 (put symbol 'customized-face nil) 2654 (put symbol 'customized-face nil)
2655 (put symbol 'face-comment comment)
2656 (put symbol 'customized-face-comment nil)
2657 (put symbol 'saved-face-comment comment)
2407 (custom-save-all) 2658 (custom-save-all)
2408 (custom-face-state-set widget) 2659 (custom-face-state-set widget)
2409 (custom-redraw-magic widget))) 2660 (custom-redraw-magic widget)))
2410 2661
2411 (defun custom-face-reset-saved (widget) 2662 (defun custom-face-reset-saved (widget)
2412 "Restore WIDGET to the face's default attributes." 2663 "Restore WIDGET to the face's default attributes."
2413 (let* ((symbol (widget-value widget)) 2664 (let* ((symbol (widget-value widget))
2414 (child (car (widget-get widget :children))) 2665 (child (car (widget-get widget :children)))
2415 (value (get symbol 'saved-face))) 2666 (value (get symbol 'saved-face))
2416 (unless value 2667 (comment (get symbol 'saved-face-comment))
2668 (comment-widget (widget-get widget :comment-widget)))
2669 (unless (or value comment)
2417 (signal 'error (list "No saved value for this face" symbol))) 2670 (signal 'error (list "No saved value for this face" symbol)))
2418 (put symbol 'customized-face nil) 2671 (put symbol 'customized-face nil)
2419 (face-spec-set symbol value) 2672 (put symbol 'customized-face-comment nil)
2673 (face-spec-set symbol value nil '(custom))
2674 (put symbol 'face-comment comment)
2420 (widget-value-set child value) 2675 (widget-value-set child value)
2676 ;; This call manages the comment visibility
2677 (widget-value-set comment-widget (or comment ""))
2421 (custom-face-state-set widget) 2678 (custom-face-state-set widget)
2422 (custom-redraw-magic widget))) 2679 (custom-redraw-magic widget)))
2423 2680
2424 (defun custom-face-reset-standard (widget) 2681 (defun custom-face-reset-standard (widget)
2425 "Restore WIDGET to the face's standard settings." 2682 "Restore WIDGET to the face's standard settings."
2426 (let* ((symbol (widget-value widget)) 2683 (let* ((symbol (widget-value widget))
2427 (child (car (widget-get widget :children))) 2684 (child (car (widget-get widget :children)))
2428 (value (get symbol 'face-defface-spec))) 2685 (value (get symbol 'face-defface-spec))
2686 (comment-widget (widget-get widget :comment-widget)))
2429 (unless value 2687 (unless value
2430 (signal 'error (list "No standard setting for this face" symbol))) 2688 (signal 'error (list "No standard setting for this face" symbol)))
2431 (put symbol 'customized-face nil) 2689 (put symbol 'customized-face nil)
2432 (when (get symbol 'saved-face) 2690 (put symbol 'customized-face-comment nil)
2691 (when (or (get symbol 'saved-face) (get symbol 'saved-face-comment))
2433 (put symbol 'saved-face nil) 2692 (put symbol 'saved-face nil)
2693 (custom-push-theme 'theme-face symbol 'user 'reset 'standard)
2694 ;; Do not explictly save resets to standards without themes.
2695 (if (null (cdr (get symbol 'theme-face)))
2696 (put symbol 'theme-face nil))
2697 (put symbol 'saved-face-comment nil)
2434 (custom-save-all)) 2698 (custom-save-all))
2435 (face-spec-set symbol value) 2699 (face-spec-set symbol value nil '(custom))
2700 (put symbol 'face-comment nil)
2436 (widget-value-set child value) 2701 (widget-value-set child value)
2702 ;; This call manages the comment visibility
2703 (widget-value-set comment-widget "")
2437 (custom-face-state-set widget) 2704 (custom-face-state-set widget)
2438 (custom-redraw-magic widget))) 2705 (custom-redraw-magic widget)))
2439 2706
2440 ;;; The `face' Widget. 2707 ;;; The `face' Widget.
2441 2708
2501 (widget-group-match widget value))) 2768 (widget-group-match widget value)))
2502 :convert-widget 'custom-hook-convert-widget 2769 :convert-widget 'custom-hook-convert-widget
2503 :tag "Hook") 2770 :tag "Hook")
2504 2771
2505 (defun custom-hook-convert-widget (widget) 2772 (defun custom-hook-convert-widget (widget)
2506 ;; Handle `:custom-options'. 2773 ;; Handle `:options'.
2507 (let* ((options (widget-get widget :options)) 2774 (let* ((options (widget-get widget :options))
2508 (other `(editable-list :inline t 2775 (other `(editable-list :inline t
2509 :entry-format "%i %d%v" 2776 :entry-format "%i %d%v"
2510 (function :format " %v"))) 2777 (function :format " %v")))
2511 (args (if options 2778 (args (if options
2980 explicitly load that file for the settings to take effect." 3247 explicitly load that file for the settings to take effect."
2981 :type 'file 3248 :type 'file
2982 :group 'customize) 3249 :group 'customize)
2983 3250
2984 (defun custom-save-delete (symbol) 3251 (defun custom-save-delete (symbol)
2985 "Delete the call to SYMBOL form `custom-file'. 3252 "Delete the call to SYMBOL form in `custom-file'.
2986 Leave point at the location of the call, or after the last expression." 3253 Leave point at the location of the call, or after the last expression."
2987 (let ((find-file-hooks nil) 3254 (let ((find-file-hooks nil)
2988 (auto-mode-alist nil)) 3255 (auto-mode-alist nil))
2989 (set-buffer (find-file-noselect custom-file))) 3256 (set-buffer (find-file-noselect custom-file)))
2990 (goto-char (point-min)) 3257 (goto-char (point-min))
3000 (point)) 3267 (point))
3001 (point)) 3268 (point))
3002 (throw 'found nil)))))) 3269 (throw 'found nil))))))
3003 3270
3004 (defun custom-save-variables () 3271 (defun custom-save-variables ()
3005 "Save all customized variables in `custom-file'." 3272 "Save all customized variables in `custom-file'."
3006 (save-excursion 3273 (save-excursion
3007 (custom-save-delete 'custom-set-variables) 3274 (custom-save-delete 'custom-load-themes)
3008 (let ((standard-output (current-buffer))) 3275 (custom-save-delete 'custom-reset-variables)
3009 (unless (bolp) 3276 (custom-save-delete 'custom-set-variables)
3010 (princ "\n")) 3277 (custom-save-loaded-themes)
3011 (princ "(custom-set-variables") 3278 (custom-save-resets 'theme-value 'custom-reset-variables nil)
3012 (mapatoms (lambda (symbol) 3279 (let ((standard-output (current-buffer)))
3013 (let ((value (get symbol 'saved-value)) 3280 (unless (bolp)
3014 (requests (get symbol 'custom-requests)) 3281 (princ "\n"))
3015 (now (not (or (get symbol 'standard-value) 3282 (princ "(custom-set-variables")
3016 (and (not (boundp symbol)) 3283 (mapatoms (lambda (symbol)
3017 (not (get symbol 'force-value))))))) 3284 (let ((spec (car-safe (get symbol 'theme-value)))
3018 (when value 3285 (requests (get symbol 'custom-requests))
3019 (princ "\n '(") 3286 (now (not (or (get symbol 'standard-value)
3020 (prin1 symbol) 3287 (and (not (boundp symbol))
3021 (princ " ") 3288 (not (eq (get symbol 'force-value)
3022 (prin1 (car value)) 3289 'rogue))))))
3023 (cond (requests 3290 (comment (get symbol 'saved-variable-comment)))
3024 (if now 3291 (when (or (and spec (eq (car spec) 'user)
3025 (princ " t ") 3292 (eq (second spec) 'set)) comment)
3026 (princ " nil ")) 3293 (princ "\n '(")
3027 (prin1 requests) 3294 (prin1 symbol)
3028 (princ ")")) 3295 (princ " ")
3029 (now 3296 ;; This comment stuff is in the way ####
3030 (princ " t)")) 3297 ;; Is (eq (third spec) (car saved-value)) ????
3031 (t 3298 ;; (prin1 (third spec))
3032 (princ ")"))))))) 3299 (prin1 (car (get symbol 'saved-value)))
3300 (when (or now requests comment)
3301 (princ (if now " t" " nil")))
3302 (when (or comment requests)
3303 (princ " ")
3304 (prin1 requests))
3305 (when comment
3306 (princ " ")
3307 (prin1 comment))
3308 (princ ")")))))
3033 (princ ")") 3309 (princ ")")
3034 (unless (looking-at "\n") 3310 (unless (looking-at "\n")
3035 (princ "\n"))))) 3311 (princ "\n")))))
3036 3312
3313 (defvar custom-save-face-ignoring nil)
3314
3315 (defun custom-save-face-internal (symbol)
3316 (let ((theme-spec (car-safe (get symbol 'theme-face)))
3317 (comment (get symbol 'saved-face-comment))
3318 (now (not (or (get symbol 'face-defface-spec)
3319 (and (not (find-face symbol))
3320 (not (eq (get symbol 'force-face) 'rogue)))))))
3321 (when (or (and (not (memq symbol custom-save-face-ignoring))
3322 ;; Don't print default face here.
3323 theme-spec
3324 (eq (car theme-spec) 'user)
3325 (eq (second theme-spec) 'set)) comment)
3326 (princ "\n '(")
3327 (prin1 symbol)
3328 (princ " ")
3329 (prin1 (get symbol 'saved-face))
3330 (if (or comment now)
3331 (princ (if now " t" " nil")))
3332 (when comment
3333 (princ " ")
3334 (prin1 comment))
3335 (princ ")"))))
3336
3037 (defun custom-save-faces () 3337 (defun custom-save-faces ()
3038 "Save all customized faces in `custom-file'." 3338 "Save all customized faces in `custom-file'."
3039 (save-excursion 3339 (save-excursion
3340 (custom-save-delete 'custom-reset-faces)
3040 (custom-save-delete 'custom-set-faces) 3341 (custom-save-delete 'custom-set-faces)
3342 (custom-save-resets 'theme-face 'custom-reset-faces '(default))
3041 (let ((standard-output (current-buffer))) 3343 (let ((standard-output (current-buffer)))
3042 (unless (bolp) 3344 (unless (bolp)
3043 (princ "\n")) 3345 (princ "\n"))
3044 (princ "(custom-set-faces") 3346 (princ "(custom-set-faces")
3045 (let ((value (get 'default 'saved-face)))
3046 ;; The default face must be first, since it affects the others. 3347 ;; The default face must be first, since it affects the others.
3047 (when value 3348 (custom-save-face-internal 'default)
3048 (princ "\n '(default ") 3349 (let ((custom-save-face-ignoring '(default)))
3049 (prin1 value) 3350 (mapatoms #'custom-save-face-internal))
3050 (if (or (get 'default 'face-defface-spec)
3051 (and (not (find-face 'default))
3052 (not (get 'default 'force-face))))
3053 (princ ")")
3054 (princ " t)"))))
3055 (mapatoms (lambda (symbol)
3056 (let ((value (get symbol 'saved-face)))
3057 (when (and (not (eq symbol 'default))
3058 ;; Don't print default face here.
3059 value)
3060 (princ "\n '(")
3061 (prin1 symbol)
3062 (princ " ")
3063 (prin1 value)
3064 (if (or (get symbol 'face-defface-spec)
3065 (and (not (find-face symbol))
3066 (not (get symbol 'force-face))))
3067 (princ ")")
3068 (princ " t)"))))))
3069 (princ ")") 3351 (princ ")")
3070 (unless (looking-at "\n") 3352 (unless (looking-at "\n")
3071 (princ "\n"))))) 3353 (princ "\n")))))
3354
3355 (defun custom-save-resets (property setter special)
3356 (let (started-writing ignored-special)
3357 ;; (custom-save-delete setter) Done by caller
3358 (let ((standard-output (current-buffer))
3359 (mapper `(lambda (object)
3360 (let ((spec (car-safe (get object (quote ,property)))))
3361 (when (and (not (memq object ignored-special))
3362 (eq (car spec) 'user)
3363 (eq (second spec) 'reset))
3364 ;; Do not write reset statements unless necessary.
3365 (unless started-writing
3366 (setq started-writing t)
3367 (unless (bolp)
3368 (princ "\n"))
3369 (princ "(")
3370 (princ (quote ,setter))
3371 (princ "\n '(")
3372 (prin1 object)
3373 (princ " ")
3374 (prin1 (third spec))
3375 (princ ")")))))))
3376 (mapc mapper special)
3377 (setq ignored-special special)
3378 (mapatoms mapper)
3379 (when started-writing
3380 (princ ")\n")))))
3381
3382
3383 (defun custom-save-loaded-themes ()
3384 (let ((themes (reverse (get 'user 'theme-loads-themes)))
3385 (standard-output (current-buffer)))
3386 (when themes
3387 (unless (bolp) (princ "\n"))
3388 (princ "(custom-load-themes")
3389 (mapc (lambda (theme)
3390 (princ "\n '")
3391 (prin1 theme)) themes)
3392 (princ " )\n"))))
3072 3393
3073 ;;;###autoload 3394 ;;;###autoload
3074 (defun customize-save-customized () 3395 (defun customize-save-customized ()
3075 "Save all user options which have been set in this session." 3396 "Save all user options which have been set in this session."
3076 (interactive) 3397 (interactive)
3077 (mapatoms (lambda (symbol) 3398 (mapatoms (lambda (symbol)
3078 (let ((face (get symbol 'customized-face)) 3399 (let ((face (get symbol 'customized-face))
3079 (value (get symbol 'customized-value))) 3400 (value (get symbol 'customized-value))
3401 (face-comment (get symbol 'customized-face-comment))
3402 (variable-comment
3403 (get symbol 'customized-variable-comment)))
3080 (when face 3404 (when face
3081 (put symbol 'saved-face face) 3405 (put symbol 'saved-face face)
3406 (custom-push-theme 'theme-face symbol 'user 'set value)
3082 (put symbol 'customized-face nil)) 3407 (put symbol 'customized-face nil))
3083 (when value 3408 (when value
3084 (put symbol 'saved-value value) 3409 (put symbol 'saved-value value)
3085 (put symbol 'customized-value nil))))) 3410 (custom-push-theme 'theme-value symbol 'user 'set value)
3411 (put symbol 'customized-value nil))
3412 (when variable-comment
3413 (put symbol 'saved-variable-comment variable-comment)
3414 (put symbol 'customized-variable-comment nil))
3415 (when face-comment
3416 (put symbol 'saved-face-comment face-comment)
3417 (put symbol 'customized-face-comment nil)))))
3086 ;; We really should update all custom buffers here. 3418 ;; We really should update all custom buffers here.
3087 (custom-save-all)) 3419 (custom-save-all))
3088 3420
3089 ;;;###autoload 3421 ;;;###autoload
3090 (defun custom-save-all () 3422 (defun custom-save-all ()