;;; 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 <abraham@dina.kvl.dk>
-;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
+;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
;; Keywords: help, faces
;; Version: 1.9960-x
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; very slow in an average XEmacs because of the large number of
;; symbols requiring a large number of funcalls -- XEmacs with Gnus
;; can grow to some 17000 symbols without ever doing anything fancy.
-;; It would probably pay off to make a hashtable of symbols known to
+;; It would probably pay off to make a hash table of symbols known to
;; Custom, similar to custom-group-hash-table.
;; This is not top priority, because none of the functions that do
(require 'cus-load)
(require 'cus-start)
+(require 'cus-file)
;; Huh? This looks dirty!
(put 'custom-define-hook 'custom-type 'hook)
(defun custom-split-regexp-maybe (regexp)
"If REGEXP is a string, split it to a list at `\\|'.
You can get the original back with from the result with:
- (mapconcat 'identity result \"\\|\")
+ (mapconcat #'identity result \"\\|\")
IF REGEXP is not a string, return it unchanged."
(if (stringp regexp)
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)))))
(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))
\f
;;; 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
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)))
(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.
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.
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
(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)
(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 )
(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)
(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)
(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)))
(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 "*")
(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)
: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)
(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))
(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
(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)))
(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)))
(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"))
(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)))
(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)
(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.
: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
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
(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))
(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)
(unless (widget-get widget :custom-form)
(widget-put widget :custom-form custom-face-default-form))
(let* ((symbol (widget-value widget))
- (spec (or (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
'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
("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))))
(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.
"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)))
"Make the face attributes in WIDGET default."
(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)
+ (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)))
"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)
- (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)))
"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)
+ (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)))
: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"
(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))
(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 '(")
- (princ 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 '(")
- (princ 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))
(run-hooks 'custom-mode-hook))
\f
+;;;###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))
+\f
;;; The End.
(provide 'cus-edit)
projects / chise / xemacs-chise.git.1 / blobdiff