X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fcus-edit.el;h=aa670d6ddffee5ac6144e4e9476c4a495616d2e1;hb=b0360c4503dfc01c7b7e75e6170c32aa7d267291;hp=339f262a783cfa586841a4511e7405297c9d7065;hpb=33c8db8e2477d62fd8734f65475f2ed516167532;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 339f262..aa670d6 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) @@ -231,7 +232,7 @@ :group 'customize) (defgroup alloc nil - "Storage allocation and gc for GNU Emacs Lisp interpreter." + "Storage allocation and gc for XEmacs Lisp interpreter." :tag "Storage Allocation" :group 'internal) @@ -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)) @@ -560,14 +562,24 @@ groups after non-groups, if nil do not order groups at all." children))) (defun Custom-save () - "Set all modified group members and save them." + "Set all modified options and save them." (interactive) - (let ((children custom-options)) + (let ((all-children custom-options) + children) (mapc (lambda (child) (when (memq (widget-get child :custom-state) '(modified set)) - (widget-apply child :custom-save))) - children)) - (custom-save-all)) + (push child children))) + all-children) + (let ((the-children children) + child) + (while (setq child (pop the-children)) + (widget-apply child :custom-pre-save))) + (custom-save-all) + (let ((the-children children) + child) + (while (setq child (pop the-children)) + (widget-apply child :custom-post-save))) + )) (defvar custom-reset-menu '(("Current" . Custom-reset-current) @@ -608,16 +620,28 @@ when the action is chosen.") (defun Custom-reset-standard (&rest ignore) "Reset all modified, set, or saved group members to their standard settings." (interactive) - (let ((children custom-options)) + (let ((all-children custom-options) + children must-save) (mapc (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-reset-standard))) - children))) + (when (memq (widget-get child :custom-state) '(modified set saved)) + (push child children))) + all-children) + (let ((the-children children) + child) + (while (setq child (pop the-children)) + (and (widget-apply child :custom-pre-reset-standard) + (setq must-save t)))) + (and must-save (custom-save-all)) + (let ((the-children children) + child) + (while (setq child (pop the-children)) + (widget-apply child :custom-post-reset-standard))) + )) ;;; 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 +651,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 +676,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 +718,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 +747,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. " - (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))) +`: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 save variable: " + "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 +901,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 +920,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 +1057,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 +1064,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 +1099,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))) @@ -1165,7 +1225,7 @@ item in another window.\n\n")) (goto-char (point-min))) (define-widget 'custom-browse-visibility 'item - "Control visibility of of items in the customize tree browser." + "Control visibility of items in the customize tree browser." :format "%[[%t]%]" :action 'custom-browse-visibility-action) @@ -1211,7 +1271,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 +1765,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) @@ -1739,10 +1870,14 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." :value-create 'custom-variable-value-create :action 'custom-variable-action :custom-set 'custom-variable-set + :custom-pre-save 'custom-variable-pre-save :custom-save 'custom-variable-save + :custom-post-save 'custom-variable-post-save :custom-reset-current 'custom-redraw :custom-reset-saved 'custom-variable-reset-saved - :custom-reset-standard 'custom-variable-reset-standard) + :custom-pre-reset-standard 'custom-variable-pre-reset-standard + :custom-reset-standard 'custom-variable-reset-standard + :custom-post-reset-standard 'custom-variable-post-reset-standard) (defun custom-variable-type (symbol) "Return a widget suitable for editing the value of SYMBOL. @@ -1870,23 +2005,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. + (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 +2062,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 +2107,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 +2117,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,28 +2170,46 @@ 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))) -(defun custom-variable-save (widget) - "Set and save the value for the variable being edited by WIDGET." +(defun custom-variable-pre-save (widget) + "Prepare for saving the value for the variable being edited by WIDGET." (let* ((form (widget-get widget :custom-form)) (state (widget-get widget :custom-state)) (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,44 +2217,101 @@ 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) - (custom-save-all) - (custom-variable-state-set widget) - (custom-redraw-magic widget))) + (put symbol 'customized-variable-comment nil) + )) + +(defun custom-variable-post-save (widget) + "Finish saving the variable being edited by WIDGET." + (custom-variable-state-set widget) + (custom-redraw-magic widget)) + +(defun custom-variable-save (widget) + "Set and save the value for the variable being edited by WIDGET." + (custom-variable-pre-save widget) + (custom-save-all) + (custom-variable-post-save widget)) (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) - "Restore the standard setting for the variable being edited by WIDGET." +;; This function returns non nil if we need to re-save the options --dv. +(defun custom-variable-pre-reset-standard (widget) + "Prepare for restoring the variable being edited by WIDGET to its +standard setting." (let* ((symbol (widget-value widget)) (set (or (get symbol 'custom-set) 'set-default))) (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-save-all)) - (widget-put widget :custom-state 'unknown) - (custom-redraw widget))) + (custom-push-theme 'theme-value symbol 'user 'reset 'standard) + ;; As a special optimizations we do not (explictly) + ;; save resets to standard when no theme sets the value. + (if (null (cdr (get symbol 'theme-value))) + (put symbol 'theme-value nil)) + (put symbol 'saved-variable-comment nil) + widget) + )) + +(defun custom-variable-post-reset-standard (widget) + "Finish resetting the variable being edited by WIDGET to its standard +value." + (widget-put widget :custom-state 'unknown) + ;; This call will possibly make the comment invisible + (custom-redraw widget)) + +(defun custom-variable-reset-standard (widget) + "Restore the standard setting for the variable being edited by WIDGET." + (when (custom-variable-pre-reset-standard widget) + (custom-save-all)) + (custom-variable-post-reset-standard widget)) ;;; The `custom-face-edit' Widget. @@ -2080,7 +2320,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 @@ -2110,25 +2350,43 @@ Only match the specified window systems") :sibling-args (:help-echo "\ The X11 Window System") x) + (const :format "GTK " + :sibling-args (:help-echo "\ +The GTK Window System") + gtk) (const :format "PM " :sibling-args (:help-echo "\ 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 @@ -2184,10 +2442,14 @@ Match frames with dark backgrounds") :custom-category 'face :custom-form nil ; defaults to value of `custom-face-default-form' :custom-set 'custom-face-set + :custom-pre-save 'custom-face-pre-save :custom-save 'custom-face-save + :custom-post-save 'custom-face-post-save :custom-reset-current 'custom-redraw :custom-reset-saved 'custom-face-reset-saved + :custom-pre-reset-standard 'custom-face-pre-reset-standard :custom-reset-standard 'custom-face-reset-standard + :custom-post-reset-standard 'custom-face-post-reset-standard :custom-menu 'custom-face-menu-create) (define-widget 'custom-face-all 'editable-list @@ -2225,6 +2487,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 +2537,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) @@ -2288,12 +2561,7 @@ Match frames with dark backgrounds") (unless (widget-get widget :custom-form) (widget-put widget :custom-form custom-face-default-form)) (let* ((symbol (widget-value widget)) - (spec (or (get symbol 'customized-face) - (get symbol 'saved-face) - (get symbol 'face-defface-spec) - ;; Attempt to construct it. - (list (list t (face-custom-attributes-get - symbol (selected-frame)))))) + (spec (custom-face-get-spec symbol)) (form (widget-get widget :custom-form)) (indent (widget-get widget :indent)) (edit (widget-create-child-and-convert @@ -2312,7 +2580,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 @@ -2320,11 +2589,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)))) @@ -2361,15 +2633,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. @@ -2390,52 +2677,113 @@ 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) + (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))) -(defun custom-face-save (widget) - "Make the face attributes in WIDGET default." +(defun custom-face-pre-save (widget) + "Prepare for saving the face being edited by WIDGET." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) - (value (widget-value child))) - (face-spec-set symbol value) + (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) - (custom-save-all) - (custom-face-state-set widget) - (custom-redraw-magic widget))) + (put symbol 'face-comment comment) + (put symbol 'customized-face-comment nil) + (put symbol 'saved-face-comment comment) + )) + +(defun custom-face-post-save (widget) + "Finish saving the face being edited by WIDGET." + (custom-face-state-set widget) + (custom-redraw-magic widget)) + +(defun custom-face-save (widget) + "Save the face being edited by WIDGET." + (custom-face-pre-save widget) + (custom-save-all) + (custom-face-post-save widget)) (defun custom-face-reset-saved (widget) - "Restore WIDGET to the face's default attributes." + "Reset the face being edited by WIDGET to its saved value." (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) - (face-spec-set symbol value) + (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))) -(defun custom-face-reset-standard (widget) - "Restore WIDGET to the face's standard settings." +;; This function returns non nil if we need to re-save the options --dv. +(defun custom-face-pre-reset-standard (widget) + "Prepare for restoring the face edited by WIDGET to its standard +settings." (let* ((symbol (widget-value widget)) - (child (car (widget-get widget :children))) (value (get symbol 'face-defface-spec))) (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-save-all)) - (face-spec-set symbol value) + (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) + widget) + )) + +(defun custom-face-post-reset-standard (widget) + "Finish restoring the face edited by WIDGET to its standard settings." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (get symbol 'face-defface-spec)) + (comment-widget (widget-get widget :comment-widget))) + (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))) + (custom-redraw-magic widget) + )) + +(defun custom-face-reset-standard (widget) + "Restore the face edited by WIDGET to its standard settings." + (when (custom-face-pre-reset-standard widget) + (custom-save-all)) + (custom-face-post-reset-standard widget)) + ;;; The `face' Widget. @@ -2503,7 +2851,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" @@ -2608,10 +2956,14 @@ and so forth. The remaining group tags are shown with :action 'custom-group-action :custom-category 'group :custom-set 'custom-group-set + :custom-pre-save 'custom-group-pre-save :custom-save 'custom-group-save + :custom-post-save 'custom-group-post-save :custom-reset-current 'custom-group-reset-current :custom-reset-saved 'custom-group-reset-saved + :custom-pre-reset-standard 'custom-group-pre-reset-standard :custom-reset-standard 'custom-group-reset-standard + :custom-post-reset-standard 'custom-group-post-reset-standard :custom-menu 'custom-group-menu-create) (defun custom-group-sample-face-get (widget) @@ -2920,14 +3272,28 @@ Optional EVENT is the location for the menu." (widget-apply child :custom-set))) children))) -(defun custom-group-save (widget) +(defun custom-group-pre-save (widget) + "Prepare for saving all modified group members." + (let ((children (widget-get widget :children))) + (mapc (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-pre-save))) + children))) + +(defun custom-group-post-save (widget) "Save all modified group members." (let ((children (widget-get widget :children))) (mapc (lambda (child) (when (memq (widget-get child :custom-state) '(modified set)) - (widget-apply child :custom-save))) + (widget-apply child :custom-post-save))) children))) +(defun custom-group-save (widget) + "Save all modified group members." + (custom-group-pre-save widget) + (custom-save-all) + (custom-group-post-save widget)) + (defun custom-group-reset-current (widget) "Reset all modified group members." (let ((children (widget-get widget :children))) @@ -2944,15 +3310,35 @@ Optional EVENT is the location for the menu." (widget-apply child :custom-reset-saved))) children))) -(defun custom-group-reset-standard (widget) - "Reset all modified, set, or saved group members." +;; This function returns non nil when we need to re-save the options --dv. +(defun custom-group-pre-reset-standard (widget) + "Prepare for resetting all modified, set, or saved group members." + (let ((children (widget-get widget :children)) + must-save) + (mapc (lambda (child) + (when (memq (widget-get child :custom-state) + '(modified set saved)) + (and (widget-apply child :custom-pre-reset-standard) + (setq must-save t)))) + children) + must-save + )) + +(defun custom-group-post-reset-standard (widget) + "Finish resetting all modified, set, or saved group members." (let ((children (widget-get widget :children))) (mapc (lambda (child) (when (memq (widget-get child :custom-state) '(modified set saved)) - (widget-apply child :custom-reset-standard))) + (widget-apply child :custom-post-reset-standard))) children))) +(defun custom-group-reset-standard (widget) + "Reset all modified, set, or saved group members." + (when (custom-group-pre-reset-standard widget) + (custom-save-all)) + (custom-group-post-reset-standard widget)) + (defun custom-group-state-update (widget) "Update magic." (unless (eq (widget-get widget :custom-state) 'hidden) @@ -2972,17 +3358,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)) @@ -3002,87 +3379,201 @@ 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 ")"))))))) - (princ ")") - (unless (looking-at "\n") - (princ "\n"))))) + "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") + + ;; Get the list of variables to save... + (let (varlist) + (mapatoms (lambda (symbol) + (let ((spec (car-safe (get symbol 'theme-value))) + (comment (get symbol 'saved-variable-comment))) + (when (or (and spec + (eq (first spec) 'user) + (eq (second spec) 'set)) + comment + ;; support non-themed vars + (and (null spec) (get symbol 'saved-value))) + (push symbol varlist))))) + + ;; ...and sort it by name, so our output can be easily diffed, etc. + (setq varlist (sort varlist #'string-lessp)) + + ;; Generate the output for each var. + (dolist (symbol varlist) + (let ((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)) + ;; Print everything, no placeholders `...' + (print-level nil) + (print-length nil)) + (princ "\n '(") + (prin1 symbol) + (princ " ") + (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 ")")))) + + ;; Finish the output. + (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)))))) + ;; Print everything, no placeholders `...' + (print-level nil) + (print-length nil)) + (when (or (and (not (memq symbol custom-save-face-ignoring)) + ;; Don't print default face here. + (or (and theme-spec + (eq (car theme-spec) 'user) + (eq (second theme-spec) 'set)) + ;; cope with non-themed faces + (and (null theme-spec) + (get symbol 'saved-face)))) + 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) - (let ((standard-output (current-buffer))) + (custom-save-resets 'theme-face 'custom-reset-faces '(default)) + (let ((standard-output (current-buffer)) + (sorted-list ())) + ;; Create a sorted list of faces + (mapatoms + (lambda (symbol) + (let ((theme-spec (car-safe (get symbol 'theme-face))) + (comment (get symbol 'saved-face-comment))) + (when + (or (and (not (memq symbol custom-save-face-ignoring)) + ;; Don't print default face here. + (or (and theme-spec + (eq (car theme-spec) 'user) + (eq (second theme-spec) 'set)) + ;; cope with non-themed faces + (and (null theme-spec) + (get symbol 'saved-face)))) + comment) + (push symbol sorted-list))))) + (setq sorted-list (sort sorted-list 'string<)) (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))) + (mapc 'custom-save-face-internal + sorted-list)) (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)))) + (print-level nil) + (print-length nil)) + (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)) + (print-level nil) + (print-length nil)) + (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)) @@ -3262,6 +3753,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)