Mercurial > hg > xemacs-beta

comparison lisp/cus-edit.el @ 412:697ef44129c6 r21-2-14

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