X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Fcus-edit.el;h=b27db594d252b9efbac4ddfba2397dd0124b2730;hp=efe6ffb867958994c4ebebee4b1f969b018657ca;hb=3198ed8319f99e19a14447745f4f93e4b4522961;hpb=2416430cb588c7f7a7ca990d536c092f3af3a0b9 diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index efe6ffb..b27db59 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1,9 +1,9 @@ ;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages. ;; -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen -;; Maintainer: Hrvoje Niksic +;; Maintainer: Hrvoje Niksic ;; Keywords: help, faces ;; Version: 1.9960-x ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ @@ -55,6 +55,7 @@ (require 'cus-load) (require 'cus-start) +(require 'cus-file) ;; Huh? This looks dirty! (put 'custom-define-hook 'custom-type 'hook) @@ -303,7 +304,8 @@ Return a list suitable for use in `interactive'." obarray (lambda (symbol) (and (boundp symbol) (or (get symbol 'custom-type) - (user-variable-p symbol)))) t)) + (user-variable-p symbol)))) + t nil nil (and v (symbol-name v)))) (list (if (equal val "") (if (symbolp v) v nil) (intern val))))) @@ -399,7 +401,7 @@ This only has an effect when `custom-unlispify-tag-names' or (custom-unlispify-menu-entry symbol t))) (defun custom-prefix-add (symbol prefixes) - ;; Addd SYMBOL to list of ignored PREFIXES. + ;; Add SYMBOL to list of ignored PREFIXES. (cons (or (get symbol 'custom-prefix) (concat (symbol-name symbol) "-")) prefixes)) @@ -617,7 +619,7 @@ when the action is chosen.") ;;; The Customize Commands -(defun custom-prompt-variable (prompt-var prompt-val) +(defun custom-prompt-variable (prompt-var prompt-val &optional comment) "Prompt for a variable and a value and return them as a list. PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the prompt for the value. The %s escape in PROMPT-VAL is replaced with @@ -627,10 +629,13 @@ If the variable has a `variable-interactive' property, that is used as if it were the arg to `interactive' (which see) to interactively read the value. If the variable has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value." +`:prompt-value' property of that widget will be used for reading the value. + +If optional COMMENT argument is non nil, also prompt for a comment and return +it as the third element in the list." (let* ((var (read-variable prompt-var)) - (minibuffer-help-form '(describe-variable var))) - (list var + (minibuffer-help-form '(describe-variable var)) + (val (let ((prop (get var 'variable-interactive)) (type (get var 'custom-type)) (prompt (format prompt-val var))) @@ -649,25 +654,37 @@ If the variable has a `custom-type' property, it must be a widget and the (symbol-value var)) (not (boundp var)))) (t - (eval-minibuffer prompt))))))) + (eval-minibuffer prompt)))))) + (if comment + (list var val + (read-string "Comment: " (get var 'variable-comment))) + (list var val)) + )) ;;;###autoload -(defun customize-set-value (var val) +(defun customize-set-value (var val &optional comment) "Set VARIABLE to VALUE. VALUE is a Lisp object. If VARIABLE has a `variable-interactive' property, that is used as if it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value." +`:prompt-value' property of that widget will be used for reading the value. + +If given a prefix (or a COMMENT argument), also prompt for a comment." (interactive (custom-prompt-variable "Set variable: " - "Set %s to value: ")) + "Set %s to value: " + current-prefix-arg)) - (set var val)) + (set var val) + (cond ((string= comment "") + (put var 'variable-comment nil)) + (comment + (put var 'variable-comment comment)))) ;;;###autoload -(defun customize-set-variable (var val) - "Set the default for VARIABLE to VALUE. VALUE is a Lisp object. +(defun customize-set-variable (variable value &optional comment) + "Set the default for VARIABLE to VALUE. VALUE is any Lisp object. If VARIABLE has a `custom-set' property, that is used for setting VARIABLE, otherwise `set-default' is used. @@ -679,14 +696,24 @@ If VARIABLE has a `variable-interactive' property, that is used as if it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " +`:prompt-value' property of that widget will be used for reading the value. + +If given a prefix (or a COMMENT argument), also prompt for a comment." (interactive (custom-prompt-variable "Set variable: " - "Set customized value for %s to: ")) - (funcall (or (get var 'custom-set) 'set-default) var val) - (put var 'customized-value (list (custom-quote val)))) + "Set customized value for %s to: " + current-prefix-arg)) + (funcall (or (get variable 'custom-set) 'set-default) variable value) + (put variable 'customized-value (list (custom-quote value))) + (cond ((string= comment "") + (put variable 'variable-comment nil) + (put variable 'customized-variable-comment nil)) + (comment + (put variable 'variable-comment comment) + (put variable 'customized-variable-comment comment)))) + ;;;###autoload -(defun customize-save-variable (var val) +(defun customize-save-variable (variable value &optional comment) "Set the default for VARIABLE to VALUE, and save it for future sessions. If VARIABLE has a `custom-set' property, that is used for setting VARIABLE, otherwise `set-default' is used. @@ -698,11 +725,21 @@ If VARIABLE has a `variable-interactive' property, that is used as if it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " +`:prompt-value' property of that widget will be used for reading the value. + +If given a prefix (or a COMMENT argument), also prompt for a comment." (interactive (custom-prompt-variable "Set and ave variable: " - "Set and save value for %s as: ")) - (funcall (or (get var 'custom-set) 'set-default) var val) - (put var 'saved-value (list (custom-quote val))) + "Set and save value for %s as: " + current-prefix-arg)) + (funcall (or (get variable 'custom-set) 'set-default) variable value) + (put variable 'saved-value (list (custom-quote value))) + (custom-push-theme 'theme-value variable 'user 'set (list (custom-quote value))) + (cond ((string= comment "") + (put variable 'variable-comment nil) + (put variable 'saved-variable-comment nil)) + (comment + (put variable 'variable-comment comment) + (put variable 'saved-variable-comment comment))) (custom-save-all)) ;;;###autoload @@ -842,10 +879,12 @@ If SYMBOL is nil, customize all faces." (interactive) (let ((found nil)) (mapatoms (lambda (symbol) - (and (get symbol 'customized-face) + (and (or (get symbol 'customized-face) + (get symbol 'customized-face-comment)) (find-face symbol) (push (list symbol 'custom-face) found)) - (and (get symbol 'customized-value) + (and (or (get symbol 'customized-value) + (get symbol 'customized-variable-comment)) (boundp symbol) (push (list symbol 'custom-variable) found)))) (if (not found) @@ -859,10 +898,12 @@ If SYMBOL is nil, customize all faces." (interactive) (let ((found nil)) (mapatoms (lambda (symbol) - (and (get symbol 'saved-face) + (and (or (get symbol 'saved-face) + (get symbol 'saved-face-comment)) (find-face symbol) (push (list symbol 'custom-face) found)) - (and (get symbol 'saved-value) + (and (or (get symbol 'saved-value) + (get symbol 'saved-variable-comment)) (boundp symbol) (push (list symbol 'custom-variable) found)))) (if (not found ) @@ -994,7 +1035,6 @@ This works by calling the function specified by (widget-insert "\nOperate on everything in this buffer:\n ") (widget-create 'push-button :tag "Set" - :tag-glyph '("set-up" "set-down") :help-echo "\ Make your editing in this buffer take effect for this session" :action (lambda (widget &optional event) @@ -1002,7 +1042,6 @@ Make your editing in this buffer take effect for this session" (widget-insert " ") (widget-create 'push-button :tag "Save" - :tag-glyph '("save-up" "save-down") :help-echo "\ Make your editing in this buffer take effect for future Emacs sessions" :action (lambda (widget &optional event) @@ -1038,7 +1077,6 @@ Reset all values in this buffer to their standard settings" (widget-insert " ") (widget-create 'push-button :tag "Done" - :tag-glyph '("done-up" "done-down") :help-echo "Remove the buffer" :action (lambda (widget &optional event) (Custom-buffer-done))) @@ -1211,7 +1249,7 @@ item in another window.\n\n")) (defun custom-browse-insert-prefix (prefix) "Insert PREFIX. On XEmacs convert it to line graphics." - ;; ### Unfinished. + ;; #### Unfinished. (if nil ; (string-match "XEmacs" emacs-version) (progn (insert "*") @@ -1705,6 +1743,77 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." (delete-region start (point))) found)) +;;; The `custom-comment' Widget. + +;; like the editable field +(defface custom-comment-face '((((class grayscale color) + (background light)) + (:background "gray85")) + (((class grayscale color) + (background dark)) + (:background "dim gray")) + (t + (:italic t))) + "Face used for comments on variables or faces" + :group 'custom-faces) + +;; like font-lock-comment-face +(defface custom-comment-tag-face + '((((class color) (background dark)) (:foreground "gray80")) + (((class color) (background light)) (:foreground "blue4")) + (((class grayscale) (background light)) + (:foreground "DimGray" :bold t :italic t)) + (((class grayscale) (background dark)) + (:foreground "LightGray" :bold t :italic t)) + (t (:bold t))) + "Face used for variables or faces comment tags" + :group 'custom-faces) + +(define-widget 'custom-comment 'string + "User comment" + :tag "Comment" + :help-echo "Edit a comment here" + :sample-face 'custom-comment-tag-face + :value-face 'custom-comment-face + :value-set 'custom-comment-value-set + :create 'custom-comment-create + :delete 'custom-comment-delete) + +(defun custom-comment-create (widget) + (let (ext) + (widget-default-create widget) + (widget-put widget :comment-extent + (setq ext (make-extent (widget-get widget :from) + (widget-get widget :to)))) + (set-extent-property ext 'start-open t) + (when (equal (widget-get widget :value) "") + (set-extent-property ext 'invisible t)) + )) + +(defun custom-comment-delete (widget) + (widget-default-delete widget) + (delete-extent (widget-get widget :comment-extent))) + +(defun custom-comment-value-set (widget value) + (widget-default-value-set widget value) + (if (equal value "") + (set-extent-property (widget-get widget :comment-extent) + 'invisible t) + (set-extent-property (widget-get widget :comment-extent) + 'invisible nil))) + +;; Those functions are for the menu. WIDGET is NOT the comment widget. It's +;; the global custom one +(defun custom-comment-show (widget) + (set-extent-property + (widget-get (widget-get widget :comment-widget) :comment-extent) + 'invisible nil)) + +(defun custom-comment-invisible-p (widget) + (extent-property + (widget-get (widget-get widget :comment-widget) :comment-extent) + 'invisible)) + ;;; The `custom-variable' Widget. (defface custom-variable-tag-face '((((class color) @@ -1870,23 +1979,40 @@ Otherwise, look up symbol in `custom-guess-type-alist'." :value value) children)))) (unless (eq custom-buffer-style 'tree) - ;; Now update the state. (unless (eq (preceding-char) ?\n) (widget-insert "\n")) - (if (eq state 'hidden) - (widget-put widget :custom-state state) - (custom-variable-state-set widget)) ;; Create the magic button. (let ((magic (widget-create-child-and-convert widget 'custom-magic nil))) (widget-put widget :custom-magic magic) (push magic buttons)) - ;; Update properties. - (widget-put widget :custom-form form) - (widget-put widget :buttons buttons) - (widget-put widget :children children) ;; Insert documentation. + ;; #### NOTE: this is ugly!!!! I need to do update the :buttons property + ;; before the call to `widget-default-format-handler'. Otherwise, I + ;; lose my current `buttons'. This function shouldn't be called like + ;; this anyway. The doc string widget should be added like the others. + ;; --dv + (widget-put widget :buttons buttons) (widget-default-format-handler widget ?h) + ;; The comment field + (unless (eq state 'hidden) + (let* ((comment (get symbol 'variable-comment)) + (comment-widget + (widget-create-child-and-convert + widget 'custom-comment + :parent widget + :value (or comment "")))) + (widget-put widget :comment-widget comment-widget) + ;; Don't push it !!! Custom assumes that the first child is the + ;; value one. + (setq children (append children (list comment-widget))))) + ;; Update the rest of the properties properties. + (widget-put widget :custom-form form) + (widget-put widget :children children) + ;; Now update the state. + (if (eq state 'hidden) + (widget-put widget :custom-state state) + (custom-variable-state-set widget)) ;; See also. (unless (eq state 'hidden) (when (eq (widget-get widget :custom-level) 1) @@ -1910,22 +2036,32 @@ Otherwise, look up symbol in `custom-guess-type-alist'." (value (if (default-boundp symbol) (funcall get symbol) (widget-get widget :value))) + (comment (get symbol 'variable-comment)) tmp - (state (cond ((setq tmp (get symbol 'customized-value)) + temp + (state (cond ((progn (setq tmp (get symbol 'customized-value)) + (setq temp + (get symbol 'customized-variable-comment)) + (or tmp temp)) (if (condition-case nil - (equal value (eval (car tmp))) + (and (equal value (eval (car tmp))) + (equal comment temp)) (error nil)) 'set 'changed)) - ((setq tmp (get symbol 'saved-value)) + ((progn (setq tmp (get symbol 'saved-value)) + (setq temp (get symbol 'saved-variable-comment)) + (or tmp temp)) (if (condition-case nil - (equal value (eval (car tmp))) + (and (equal value (eval (car tmp))) + (equal comment temp)) (error nil)) 'saved 'changed)) ((setq tmp (get symbol 'standard-value)) (if (condition-case nil - (equal value (eval (car tmp))) + (and (equal value (eval (car tmp))) + (equal comment nil)) (error nil)) 'standard 'changed)) @@ -1945,7 +2081,8 @@ Otherwise, look up symbol in `custom-guess-type-alist'." (memq (widget-get widget :custom-state) '(modified changed))))) ("Reset to Saved" custom-variable-reset-saved (lambda (widget) - (and (get (widget-value widget) 'saved-value) + (and (or (get (widget-value widget) 'saved-value) + (get (widget-value widget) 'saved-variable-comment)) (memq (widget-get widget :custom-state) '(modified set changed rogue))))) ("Reset to Standard Settings" custom-variable-reset-standard @@ -1954,6 +2091,8 @@ Otherwise, look up symbol in `custom-guess-type-alist'." (memq (widget-get widget :custom-state) '(modified set changed saved rogue))))) ("---" ignore ignore) + ("Add Comment" custom-comment-show custom-comment-invisible-p) + ("---" ignore ignore) ("Don't show as Lisp expression" custom-variable-edit (lambda (widget) (eq (widget-get widget :custom-form) 'lisp))) @@ -2005,18 +2144,34 @@ Optional EVENT is the location for the menu." (child (car (widget-get widget :children))) (symbol (widget-value widget)) (set (or (get symbol 'custom-set) 'set-default)) - val) + (comment-widget (widget-get widget :comment-widget)) + (comment (widget-value comment-widget)) + val) (cond ((eq state 'hidden) (error "Cannot set hidden variable")) ((setq val (widget-apply child :validate)) (goto-char (widget-get val :from)) (error "%s" (widget-get val :error))) ((memq form '(lisp mismatch)) + (when (equal comment "") + (setq comment nil) + ;; Make the comment invisible by hand if it's empty + (set-extent-property (widget-get comment-widget :comment-extent) + 'invisible t)) (funcall set symbol (eval (setq val (widget-value child)))) - (put symbol 'customized-value (list val))) + (put symbol 'customized-value (list val)) + (put symbol 'variable-comment comment) + (put symbol 'customized-variable-comment comment)) (t + (when (equal comment "") + (setq comment nil) + ;; Make the comment invisible by hand if it's empty + (set-extent-property (widget-get comment-widget :comment-extent) + 'invisible t)) (funcall set symbol (setq val (widget-value child))) - (put symbol 'customized-value (list (custom-quote val))))) + (put symbol 'customized-value (list (custom-quote val))) + (put symbol 'variable-comment comment) + (put symbol 'customized-variable-comment comment))) (custom-variable-state-set widget) (custom-redraw-magic widget))) @@ -2027,6 +2182,8 @@ Optional EVENT is the location for the menu." (child (car (widget-get widget :children))) (symbol (widget-value widget)) (set (or (get symbol 'custom-set) 'set-default)) + (comment-widget (widget-get widget :comment-widget)) + (comment (widget-value comment-widget)) val) (cond ((eq state 'hidden) (error "Cannot set hidden variable")) @@ -2034,14 +2191,34 @@ Optional EVENT is the location for the menu." (goto-char (widget-get val :from)) (error "%s" (widget-get val :error))) ((memq form '(lisp mismatch)) + (when (equal comment "") + (setq comment nil) + ;; Make the comment invisible by hand if it's empty + (set-extent-property (widget-get comment-widget :comment-extent) + 'invisible t)) (put symbol 'saved-value (list (widget-value child))) - (funcall set symbol (eval (widget-value child)))) + (custom-push-theme 'theme-value symbol 'user + 'set (list (widget-value child))) + (funcall set symbol (eval (widget-value child))) + (put symbol 'variable-comment comment) + (put symbol 'saved-variable-comment comment)) (t + (when (equal comment "") + (setq comment nil) + ;; Make the comment invisible by hand if it's empty + (set-extent-property (widget-get comment-widget :comment-extent) + 'invisible t)) (put symbol 'saved-value (list (custom-quote (widget-value child)))) - (funcall set symbol (widget-value child)))) + (custom-push-theme 'theme-value symbol 'user + 'set (list (custom-quote (widget-value + child)))) + (funcall set symbol (widget-value child)) + (put symbol 'variable-comment comment) + (put symbol 'saved-variable-comment comment))) (put symbol 'customized-value nil) + (put symbol 'customized-variable-comment nil) (custom-save-all) (custom-variable-state-set widget) (custom-redraw-magic widget))) @@ -2049,14 +2226,20 @@ Optional EVENT is the location for the menu." (defun custom-variable-reset-saved (widget) "Restore the saved value for the variable being edited by WIDGET." (let* ((symbol (widget-value widget)) - (set (or (get symbol 'custom-set) 'set-default))) - (if (get symbol 'saved-value) - (condition-case nil - (funcall set symbol (eval (car (get symbol 'saved-value)))) - (error nil)) - (signal 'error (list "No saved value for variable" symbol))) + (set (or (get symbol 'custom-set) 'set-default)) + (value (get symbol 'saved-value)) + (comment (get symbol 'saved-variable-comment))) + (cond ((or value comment) + (put symbol 'variable-comment comment) + (condition-case nil + (funcall set symbol (eval (car value))) + (error nil))) + (t + (signal 'error (list "No saved value for variable" symbol)))) (put symbol 'customized-value nil) + (put symbol 'customized-variable-comment nil) (widget-put widget :custom-state 'unknown) + ;; This call will possibly make the comment invisible (custom-redraw widget))) (defun custom-variable-reset-standard (widget) @@ -2066,11 +2249,20 @@ Optional EVENT is the location for the menu." (if (get symbol 'standard-value) (funcall set symbol (eval (car (get symbol 'standard-value)))) (signal 'error (list "No standard setting known for variable" symbol))) + (put symbol 'variable-comment nil) (put symbol 'customized-value nil) - (when (get symbol 'saved-value) + (put symbol 'customized-variable-comment nil) + (when (or (get symbol 'saved-value) (get symbol 'saved-variable-comment)) (put symbol 'saved-value nil) + (custom-push-theme 'theme-value symbol 'user 'reset 'standard) + ;; As a special optimizations we do not (explictly) + ;; save resets to standard when no theme set the value. + (if (null (cdr (get symbol 'theme-value))) + (put symbol 'theme-value nil)) + (put symbol 'saved-variable-comment nil) (custom-save-all)) (widget-put widget :custom-state 'unknown) + ;; This call will possibly make the comment invisible (custom-redraw widget))) ;;; The `custom-face-edit' Widget. @@ -2080,7 +2272,7 @@ Optional EVENT is the location for the menu." :format "%t: %v" :tag "Attributes" :extra-offset 12 - :button-args '(:help-echo "Control whether this attribute have any effect") + :button-args '(:help-echo "Control whether this attribute has any effect") :args (mapcar (lambda (att) (list 'group :inline t @@ -2116,19 +2308,33 @@ OS/2 Presentation Manager") pm) (const :format "MSWindows " :sibling-args (:help-echo "\ -Windows NT/95/97") +Microsoft Windows, displays") mswindows) - (const :format "DOS " + (const :format "MSPrinter " :sibling-args (:help-echo "\ -Plain MS-DOS") - pc) +Microsoft Windows, printers") + msprinter) (const :format "TTY%n" :sibling-args (:help-echo "\ Plain text terminals") tty))) (group :sibling-args (:help-echo "\ +Only match display or printer devices") + (const :format "Output: " + class) + (checklist :inline t + :offset 0 + (const :format "Display " + :sibling-args (:help-echo "\ +Match display devices") + display) + (const :format "Printer%n" + :sibling-args (:help-echo "\ +Match printer devices") + printer))) + (group :sibling-args (:help-echo "\ Only match the frames with the specified color support") - (const :format "Class: " + (const :format "Color support: " class) (checklist :inline t :offset 0 @@ -2225,6 +2431,7 @@ Match frames with dark backgrounds") (defun custom-face-value-create (widget) "Create a list of the display specifications for WIDGET." (let ((buttons (widget-get widget :buttons)) + children (symbol (widget-get widget :value)) (tag (widget-get widget :tag)) (state (widget-get widget :custom-state)) @@ -2274,6 +2481,16 @@ Match frames with dark backgrounds") (widget-put widget :buttons buttons) ;; Insert documentation. (widget-default-format-handler widget ?h) + ;; The comment field + (unless (eq state 'hidden) + (let* ((comment (get symbol 'face-comment)) + (comment-widget + (widget-create-child-and-convert + widget 'custom-comment + :parent widget + :value (or comment "")))) + (widget-put widget :comment-widget comment-widget) + (push comment-widget children))) ;; See also. (unless (eq state 'hidden) (when (eq (widget-get widget :custom-level) 1) @@ -2307,7 +2524,8 @@ Match frames with dark backgrounds") 'sexp)) :value spec))) (custom-face-state-set widget) - (widget-put widget :children (list edit))) + (push edit children) + (widget-put widget :children children)) (message "Creating face editor...done")))))) (defvar custom-face-menu @@ -2315,11 +2533,14 @@ Match frames with dark backgrounds") ("Save for Future Sessions" custom-face-save) ("Reset to Saved" custom-face-reset-saved (lambda (widget) - (get (widget-value widget) 'saved-face))) + (or (get (widget-value widget) 'saved-face) + (get (widget-value widget) 'saved-face-comment)))) ("Reset to Standard Setting" custom-face-reset-standard (lambda (widget) (get (widget-value widget) 'face-defface-spec))) ("---" ignore ignore) + ("Add Comment" custom-comment-show custom-comment-invisible-p) + ("---" ignore ignore) ("Show all display specs" custom-face-edit-all (lambda (widget) (not (eq (widget-get widget :custom-form) 'all)))) @@ -2356,15 +2577,30 @@ widget. If FILTER is nil, ACTION is always valid.") (defun custom-face-state-set (widget) "Set the state of WIDGET." - (let ((symbol (widget-value widget))) - (widget-put widget :custom-state (cond ((get symbol 'customized-face) - 'set) - ((get symbol 'saved-face) - 'saved) - ((get symbol 'face-defface-spec) - 'standard) - (t - 'rogue))))) + (let* ((symbol (widget-value widget)) + (comment (get symbol 'face-comment)) + tmp temp) + (widget-put widget :custom-state + (cond ((progn + (setq tmp (get symbol 'customized-face)) + (setq temp (get symbol 'customized-face-comment)) + (or tmp temp)) + (if (equal temp comment) + 'set + 'changed)) + ((progn + (setq tmp (get symbol 'saved-face)) + (setq temp (get symbol 'saved-face-comment)) + (or tmp temp)) + (if (equal temp comment) + 'saved + 'changed)) + ((get symbol 'face-defface-spec) + (if (equal comment nil) + 'standard + 'changed)) + (t + 'rogue))))) (defun custom-face-action (widget &optional event) "Show the menu for `custom-face' WIDGET. @@ -2385,9 +2621,18 @@ Optional EVENT is the location for the menu." "Make the face attributes in WIDGET take effect." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) - (value (widget-value child))) + (value (widget-value child)) + (comment-widget (widget-get widget :comment-widget)) + (comment (widget-value comment-widget))) + (when (equal comment "") + (setq comment nil) + ;; Make the comment invisible by hand if it's empty + (set-extent-property (widget-get comment-widget :comment-extent) + 'invisible t)) (put symbol 'customized-face value) (face-spec-set symbol value nil '(custom)) + (put symbol 'customized-face-comment comment) + (put symbol 'face-comment comment) (custom-face-state-set widget) (custom-redraw-magic widget))) @@ -2395,10 +2640,21 @@ Optional EVENT is the location for the menu." "Make the face attributes in WIDGET default." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) - (value (widget-value child))) + (value (widget-value child)) + (comment-widget (widget-get widget :comment-widget)) + (comment (widget-value comment-widget))) + (when (equal comment "") + (setq comment nil) + ;; Make the comment invisible by hand if it's empty + (set-extent-property (widget-get comment-widget :comment-extent) + 'invisible t)) (face-spec-set symbol value nil '(custom)) (put symbol 'saved-face value) + (custom-push-theme 'theme-face symbol 'user 'set value) (put symbol 'customized-face nil) + (put symbol 'face-comment comment) + (put symbol 'customized-face-comment nil) + (put symbol 'saved-face-comment comment) (custom-save-all) (custom-face-state-set widget) (custom-redraw-magic widget))) @@ -2407,12 +2663,18 @@ Optional EVENT is the location for the menu." "Restore WIDGET to the face's default attributes." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) - (value (get symbol 'saved-face))) - (unless value + (value (get symbol 'saved-face)) + (comment (get symbol 'saved-face-comment)) + (comment-widget (widget-get widget :comment-widget))) + (unless (or value comment) (signal 'error (list "No saved value for this face" symbol))) (put symbol 'customized-face nil) + (put symbol 'customized-face-comment nil) (face-spec-set symbol value nil '(custom)) + (put symbol 'face-comment comment) (widget-value-set child value) + ;; This call manages the comment visibility + (widget-value-set comment-widget (or comment "")) (custom-face-state-set widget) (custom-redraw-magic widget))) @@ -2420,15 +2682,25 @@ Optional EVENT is the location for the menu." "Restore WIDGET to the face's standard settings." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) - (value (get symbol 'face-defface-spec))) + (value (get symbol 'face-defface-spec)) + (comment-widget (widget-get widget :comment-widget))) (unless value (signal 'error (list "No standard setting for this face" symbol))) (put symbol 'customized-face nil) - (when (get symbol 'saved-face) + (put symbol 'customized-face-comment nil) + (when (or (get symbol 'saved-face) (get symbol 'saved-face-comment)) (put symbol 'saved-face nil) + (custom-push-theme 'theme-face symbol 'user 'reset 'standard) + ;; Do not explictly save resets to standards without themes. + (if (null (cdr (get symbol 'theme-face))) + (put symbol 'theme-face nil)) + (put symbol 'saved-face-comment nil) (custom-save-all)) (face-spec-set symbol value nil '(custom)) + (put symbol 'face-comment nil) (widget-value-set child value) + ;; This call manages the comment visibility + (widget-value-set comment-widget "") (custom-face-state-set widget) (custom-redraw-magic widget))) @@ -2498,7 +2770,7 @@ Optional EVENT is the location for the menu." :tag "Hook") (defun custom-hook-convert-widget (widget) - ;; Handle `:custom-options'. + ;; Handle `:options'. (let* ((options (widget-get widget :options)) (other `(editable-list :inline t :entry-format "%i %d%v" @@ -2967,17 +3239,8 @@ Optional EVENT is the location for the menu." (widget-put widget :custom-state found))) (custom-magic-reset widget)) -;;; The `custom-save-all' Function. -;;;###autoload -(defcustom custom-file "~/.emacs" - "File used for storing customization information. -If you change this from the default \"~/.emacs\" you need to -explicitly load that file for the settings to take effect." - :type 'file - :group 'customize) - (defun custom-save-delete (symbol) - "Delete the call to SYMBOL form `custom-file'. + "Delete the call to SYMBOL form in `custom-file'. Leave point at the location of the call, or after the last expression." (let ((find-file-hooks nil) (auto-mode-alist nil)) @@ -2997,87 +3260,154 @@ Leave point at the location of the call, or after the last expression." (throw 'found nil)))))) (defun custom-save-variables () - "Save all customized variables in `custom-file'." - (save-excursion - (custom-save-delete 'custom-set-variables) - (let ((standard-output (current-buffer))) - (unless (bolp) - (princ "\n")) - (princ "(custom-set-variables") - (mapatoms (lambda (symbol) - (let ((value (get symbol 'saved-value)) - (requests (get symbol 'custom-requests)) - (now (not (or (get symbol 'standard-value) - (and (not (boundp symbol)) - (not (get symbol 'force-value))))))) - (when value - (princ "\n '(") - (prin1 symbol) - (princ " ") - (prin1 (car value)) - (cond (requests - (if now - (princ " t ") - (princ " nil ")) - (prin1 requests) - (princ ")")) - (now - (princ " t)")) - (t - (princ ")"))))))) + "Save all customized variables in `custom-file'." + (save-excursion + (custom-save-delete 'custom-load-themes) + (custom-save-delete 'custom-reset-variables) + (custom-save-delete 'custom-set-variables) + (custom-save-loaded-themes) + (custom-save-resets 'theme-value 'custom-reset-variables nil) + (let ((standard-output (current-buffer))) + (unless (bolp) + (princ "\n")) + (princ "(custom-set-variables") + (mapatoms (lambda (symbol) + (let ((spec (car-safe (get symbol 'theme-value))) + (requests (get symbol 'custom-requests)) + (now (not (or (get symbol 'standard-value) + (and (not (boundp symbol)) + (not (eq (get symbol 'force-value) + 'rogue)))))) + (comment (get symbol 'saved-variable-comment))) + (when (or (and spec (eq (car spec) 'user) + (eq (second spec) 'set)) comment) + (princ "\n '(") + (prin1 symbol) + (princ " ") + ;; This comment stuff is in the way #### + ;; Is (eq (third spec) (car saved-value)) ???? + ;; (prin1 (third spec)) + (prin1 (car (get symbol 'saved-value))) + (when (or now requests comment) + (princ (if now " t" " nil"))) + (when (or comment requests) + (princ " ") + (prin1 requests)) + (when comment + (princ " ") + (prin1 comment)) + (princ ")"))))) (princ ")") (unless (looking-at "\n") (princ "\n"))))) +(defvar custom-save-face-ignoring nil) + +(defun custom-save-face-internal (symbol) + (let ((theme-spec (car-safe (get symbol 'theme-face))) + (comment (get symbol 'saved-face-comment)) + (now (not (or (get symbol 'face-defface-spec) + (and (not (find-face symbol)) + (not (eq (get symbol 'force-face) 'rogue))))))) + (when (or (and (not (memq symbol custom-save-face-ignoring)) + ;; Don't print default face here. + theme-spec + (eq (car theme-spec) 'user) + (eq (second theme-spec) 'set)) comment) + (princ "\n '(") + (prin1 symbol) + (princ " ") + (prin1 (get symbol 'saved-face)) + (if (or comment now) + (princ (if now " t" " nil"))) + (when comment + (princ " ") + (prin1 comment)) + (princ ")")))) + (defun custom-save-faces () "Save all customized faces in `custom-file'." (save-excursion + (custom-save-delete 'custom-reset-faces) (custom-save-delete 'custom-set-faces) + (custom-save-resets 'theme-face 'custom-reset-faces '(default)) (let ((standard-output (current-buffer))) (unless (bolp) (princ "\n")) (princ "(custom-set-faces") - (let ((value (get 'default 'saved-face))) ;; The default face must be first, since it affects the others. - (when value - (princ "\n '(default ") - (prin1 value) - (if (or (get 'default 'face-defface-spec) - (and (not (find-face 'default)) - (not (get 'default 'force-face)))) - (princ ")") - (princ " t)")))) - (mapatoms (lambda (symbol) - (let ((value (get symbol 'saved-face))) - (when (and (not (eq symbol 'default)) - ;; Don't print default face here. - value) - (princ "\n '(") - (prin1 symbol) - (princ " ") - (prin1 value) - (if (or (get symbol 'face-defface-spec) - (and (not (find-face symbol)) - (not (get symbol 'force-face)))) - (princ ")") - (princ " t)")))))) + (custom-save-face-internal 'default) + (let ((custom-save-face-ignoring '(default))) + (mapatoms #'custom-save-face-internal)) (princ ")") (unless (looking-at "\n") (princ "\n"))))) +(defun custom-save-resets (property setter special) + (let (started-writing ignored-special) + (setq ignored-special ignored-special) ;; suppress byte-compiler warning + ;; (custom-save-delete setter) Done by caller + (let ((standard-output (current-buffer)) + (mapper `(lambda (object) + (let ((spec (car-safe (get object (quote ,property))))) + (when (and (not (memq object ignored-special)) + (eq (car spec) 'user) + (eq (second spec) 'reset)) + ;; Do not write reset statements unless necessary. + (unless started-writing + (setq started-writing t) + (unless (bolp) + (princ "\n")) + (princ "(") + (princ (quote ,setter)) + (princ "\n '(") + (prin1 object) + (princ " ") + (prin1 (third spec)) + (princ ")"))))))) + (mapc mapper special) + (setq ignored-special special) + (mapatoms mapper) + (when started-writing + (princ ")\n")))) + ) + + +(defun custom-save-loaded-themes () + (let ((themes (reverse (get 'user 'theme-loads-themes))) + (standard-output (current-buffer))) + (when themes + (unless (bolp) (princ "\n")) + (princ "(custom-load-themes") + (mapc (lambda (theme) + (princ "\n '") + (prin1 theme)) themes) + (princ " )\n")))) + ;;;###autoload (defun customize-save-customized () "Save all user options which have been set in this session." (interactive) (mapatoms (lambda (symbol) (let ((face (get symbol 'customized-face)) - (value (get symbol 'customized-value))) + (value (get symbol 'customized-value)) + (face-comment (get symbol 'customized-face-comment)) + (variable-comment + (get symbol 'customized-variable-comment))) (when face (put symbol 'saved-face face) + (custom-push-theme 'theme-face symbol 'user 'set value) (put symbol 'customized-face nil)) (when value (put symbol 'saved-value value) - (put symbol 'customized-value nil))))) + (custom-push-theme 'theme-value symbol 'user 'set value) + (put symbol 'customized-value nil)) + (when variable-comment + (put symbol 'saved-variable-comment variable-comment) + (put symbol 'customized-variable-comment nil)) + (when face-comment + (put symbol 'saved-face-comment face-comment) + (put symbol 'customized-face-comment nil))))) ;; We really should update all custom buffers here. (custom-save-all)) @@ -3257,6 +3587,19 @@ if that value is non-nil." (run-hooks 'custom-mode-hook)) +;;;###autoload +(defun custom-migrate-custom-file (new-custom-file-name) + "Migrate custom file from home directory." + (mapc 'custom-save-delete + '(custom-load-themes custom-reset-variables + custom-set-variables + custom-set-faces + custom-reset-faces)) + (with-current-buffer (find-file-noselect custom-file) + (save-buffer)) + (setq custom-file new-custom-file-name) + (custom-save-all)) + ;;; The End. (provide 'cus-edit)