From 53e6c16013c1be4f855bcfc056dfe0677ae720da Mon Sep 17 00:00:00 2001 From: Dave Love Date: Wed, 17 Jan 2001 20:28:25 +0000 Subject: [PATCH] Theme changes from Schroeder. --- lisp/cus-edit.el | 244 +++++++++---- lisp/cus-face.el | 163 ++++++--- lisp/custom.el | 881 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 1172 insertions(+), 116 deletions(-) create mode 100644 lisp/custom.el diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index c7b0960c2ed..a90b1204fba 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1,8 +1,9 @@ ;;; cus-edit.el --- Tools for customizing Emacs and Lisp packages. ;; -;; Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2000, 2001 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen +;; Maintainer: FSF ;; Keywords: help, faces ;; This file is part of GNU Emacs. @@ -25,7 +26,7 @@ ;;; Commentary: ;; ;; This file implements the code to create and edit customize buffers. -;; +;; ;; See `custom.el'. ;; No commands should have names starting with `custom-' because @@ -760,7 +761,7 @@ If given a prefix (or a COMMENT argument), also prompt for a comment." (interactive (custom-prompt-variable "Set variable: " "Set %s to value: " current-prefix-arg)) - + (set var val) (cond ((string= comment "") (put var 'variable-comment nil)) @@ -817,6 +818,7 @@ If given a prefix (or a COMMENT argument), also prompt for a comment." current-prefix-arg)) (funcall (or (get var 'custom-set) 'set-default) var value) (put var 'saved-value (list (custom-quote value))) + (custom-push-theme 'theme-value var 'user 'set (list (custom-quote val))) (cond ((string= comment "") (put var 'variable-comment nil) (put var 'saved-variable-comment nil)) @@ -1012,7 +1014,7 @@ version." (or (< major1 major2) (and (= major1 major2) (< minor1 minor2))))) - + ;;;###autoload (defalias 'customize-variable-other-window 'customize-option-other-window) @@ -1295,16 +1297,7 @@ Un-customize all values in this buffer. They get their standard settings." (widget-insert " ") (widget-create 'push-button :tag "Finish" - :help-echo - (lambda (&rest ignore) - (concat (cond - ((eq custom-buffer-done-function - 'custom-bury-buffer) - "Bury") - ((eq custom-buffer-done-function 'kill-buffer) - "Kill") - (t "Finish with")) - " the buffer.")) + :help-echo "Bury or kill the buffer." :action #'Custom-buffer-done) (widget-insert "\n\n") (message "Creating customization items...") @@ -1705,7 +1698,10 @@ and `face'." ;;; The `custom' Widget. (defface custom-button-face - '((((type x w32 mac) (class color)) ; Like default modeline + '((((type x) (class color)) ; Like default modeline + (:box (:line-width 2 :style released-button) + :background "lightgrey" :foreground "black")) + (((type w32) (class color)) ; Like default modeline (:box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) (t @@ -1715,7 +1711,10 @@ and `face'." :group 'custom-faces) (defface custom-button-pressed-face - '((((type x w32 mac) (class color)) + '((((type x) (class color)) + (:box (:line-width 2 :style pressed-button) + :background "lightgrey" :foreground "black")) + (((type w32) (class color)) (:box (:line-width 2 :style pressed-button) :background "lightgrey" :foreground "black")) (t @@ -2009,10 +2008,18 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." (defface custom-variable-tag-face `((((class color) (background dark)) - (:foreground "light blue" :bold t :height 1.2 :inherit variable-pitch)) + (:foreground "light blue" :bold t :family "helv" + :height ,(let ((height (face-attribute 'default :height))) + (if (numberp height) + (floor height 0.9) + height)))) (((class color) (background light)) - (:foreground "blue" :bold t :height 1.2 :inherit variable-pitch)) + (:foreground "blue" :family "helv" :bold t + :height ,(let ((height (face-attribute 'default :height))) + (if (numberp height) + (floor height 0.9) + height)))) (t (:bold t))) "Face used for unpushable variable tags." :group 'custom-faces) @@ -2386,6 +2393,8 @@ Optional EVENT is the location for the menu." ;; Make the comment invisible by hand if it's empty (custom-comment-hide comment-widget)) (put symbol 'saved-value (list (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)) @@ -2396,6 +2405,9 @@ Optional EVENT is the location for the menu." (custom-comment-hide comment-widget)) (put symbol 'saved-value (list (custom-quote (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))) @@ -2409,6 +2421,7 @@ Optional EVENT is the location for the menu." "Restore the saved value for the variable being edited by WIDGET." (let* ((symbol (widget-value widget)) (set (or (get symbol 'custom-set) 'set-default)) + (comment-widget (widget-get widget :comment-widget)) (value (get symbol 'saved-value)) (comment (get symbol 'saved-variable-comment))) (cond ((or value comment) @@ -2429,7 +2442,8 @@ Optional EVENT is the location for the menu." This operation eliminates any saved setting for the variable, restoring it to the state of a variable that has never been customized." (let* ((symbol (widget-value widget)) - (set (or (get symbol 'custom-set) 'set-default))) + (set (or (get symbol 'custom-set) 'set-default)) + (comment-widget (widget-get widget :comment-widget))) (if (get symbol 'standard-value) (funcall set symbol (eval (car (get symbol 'standard-value)))) (error "No standard setting known for %S" symbol)) @@ -2438,6 +2452,11 @@ restoring it to the state of a variable that has never been customized." (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) @@ -2534,7 +2553,11 @@ Match frames with dark backgrounds.") ;;; The `custom-face' Widget. (defface custom-face-tag-face - `((t (:bold t :height 1.2 :inherit variable-pitch))) + `((t (:bold t :family "helv" + :height ,(let ((height (face-attribute 'default :height))) + (if (numberp height) + (floor height 0.9) + height))))) "Face used for face tags." :group 'custom-faces) @@ -2619,9 +2642,7 @@ Match frames with dark backgrounds.") (if (eq custom-buffer-style 'face) (insert " ") (widget-specify-sample widget begin (point)) - (if (string-match "face\\'" tag) - (insert ":") - (insert " face: "))) + (insert ": ")) ;; Sample. (push (widget-create-child-and-convert widget 'item :format "(%{%t%})" @@ -2827,6 +2848,7 @@ Optional EVENT is the location for the menu." (custom-comment-hide comment-widget)) (face-spec-set symbol value) (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) @@ -2868,6 +2890,10 @@ restoring it to the state of a face that has never been customized." (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) @@ -2991,10 +3017,19 @@ and so forth. The remaining group tags are shown with (defface custom-group-tag-face-1 `((((class color) (background dark)) - (:foreground "pink" :bold t :height 1.2 :inherit variable-pitch)) + (:foreground "pink" :family "helv" + :height ,(let ((height (face-attribute 'default :height))) + (if (numberp height) + (floor height 0.9) + height)) + :bold t)) (((class color) (background light)) - (:foreground "red" :bold t :height 1.2 :inherit variable-pitch)) + (:foreground "red" :bold t + :height ,(let ((height (face-attribute 'default :height))) + (if (numberp height) + (floor height 0.9) + height)))) (t (:bold t))) "Face used for group tags." :group 'custom-faces) @@ -3002,10 +3037,18 @@ and so forth. The remaining group tags are shown with (defface custom-group-tag-face `((((class color) (background dark)) - (:foreground "light blue" :bold t :height 1.2)) + (:foreground "light blue" :bold t + :height ,(let ((height (face-attribute 'default :height))) + (if (numberp height) + (floor height 0.9) + height)))) (((class color) (background light)) - (:foreground "blue" :bold t :height 1.2)) + (:foreground "blue" :bold t + :height ,(let ((height (face-attribute 'default :height))) + (if (numberp height) + (floor height 0.9) + height)))) (t (:bold t))) "Face used for low level group tags." :group 'custom-faces) @@ -3426,7 +3469,11 @@ or (if there were none) at the end of the buffer." (defun custom-save-variables () "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)) (saved-list (make-list 1 0)) sort-fold-case) @@ -3443,14 +3490,19 @@ or (if there were none) at the end of the buffer." ;; Your init file must only contain one such instance.\n") (mapcar (lambda (symbol) - (let ((value (get symbol 'saved-value)) + (let ((spec (car-safe (get symbol 'theme-value))) + (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)))))) + (not (eq (get symbol 'force-value) + 'rogue)))))) (comment (get symbol 'saved-variable-comment)) sep) - (when (or value comment) + (when (or (and spec + (eq (nth 0 spec) 'user) + (eq (nth 1 spec) 'set)) + comment) (unless (bolp) (princ "\n")) (princ " '(") @@ -3487,7 +3539,9 @@ or (if there were none) at the end of the buffer." (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)) (saved-list (make-list 1 0)) sort-fold-case) @@ -3507,32 +3561,35 @@ or (if there were none) at the end of the buffer." ;; Your init file must only contain one such instance.\n") (mapcar (lambda (symbol) - (let ((value (get symbol 'saved-face)) - (now (not (or (get 'default 'face-defface-spec) - (and (not (custom-facep 'default)) - (not (get 'default 'force-face)))))) - (comment (get 'default 'saved-face-comment))) - (unless (eq symbol 'default)) - ;; Don't print default face here. - (unless (bolp) - (princ "\n")) - (princ " '(") - (prin1 symbol) - (princ " ") - (prin1 value) - (cond ((or now comment) - (princ " ") - (if now - (princ "t") - (princ "nil")) - (cond (comment - (princ " ") - (prin1 comment) - (princ ")")) - (t - (princ ")")))) - (t - (princ ")"))))) + (let ((theme-spec (car-safe (get symbol 'theme-face))) + (value (get symbol 'saved-face)) + (now (not (or (get symbol 'face-defface-spec) + (and (not (custom-facep symbol)) + (not (eq (get symbol 'force-face) 'rogue)))))) + (comment (get symbol 'saved-face-comment))) + (when (or (and theme-spec + (eq (nth 0 theme-spec) 'user) + (eq (nth 1 theme-spec) 'set)) + comment) + (unless (bolp) + (princ "\n")) + (princ " '(") + (prin1 symbol) + (princ " ") + (prin1 value) + (cond ((or now comment) + (princ " ") + (if now + (princ "t") + (princ "nil")) + (cond (comment + (princ " ") + (prin1 comment) + (princ ")")) + (t + (princ ")")))) + (t + (princ ")")))))) saved-list) (if (bolp) (princ " ")) @@ -3540,6 +3597,44 @@ or (if there were none) at the end of the buffer." (unless (looking-at "\n") (princ "\n"))))) +(defun custom-save-resets (property setter special) + (let (started-writing ignored-special) + ;; (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 (nth 0 spec) 'user) + (eq (nth 1 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 (nth 3 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." @@ -3552,9 +3647,11 @@ or (if there were none) at the end of the buffer." (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) + (custom-push-theme 'theme-value symbol 'user 'set value) (put symbol 'customized-value nil)) (when variable-comment (put symbol 'saved-variable-comment variable-comment) @@ -3610,11 +3707,20 @@ or (if there were none) at the end of the buffer." ':style 'toggle ':selected symbol))) -(defun custom-group-menu-create (widget symbol) - "Ignoring WIDGET, create a menu entry for customization group SYMBOL." - `( ,(custom-unlispify-menu-entry symbol t) - :filter (lambda (&rest junk) - (cdr (custom-menu-create ',symbol))))) +;; Fixme: sort out use of :filter in Emacs 21. +(if nil ; (string-match "XEmacs" emacs-version) + ;; XEmacs can create menus dynamically. + (defun custom-group-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization group SYMBOL." + `( ,(custom-unlispify-menu-entry symbol t) + :filter (lambda (&rest junk) + (cdr (custom-menu-create ',symbol))))) + ;; But emacs can't. + (defun custom-group-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization group SYMBOL." + ;; Limit the nesting. + (let ((custom-menu-nesting (1- custom-menu-nesting))) + (custom-menu-create symbol)))) ;;;###autoload (defun custom-menu-create (symbol) @@ -3651,9 +3757,14 @@ Otherwise the menu will be named `Customize'. The format is suitable for use with `easy-menu-define'." (unless name (setq name "Customize")) - `(,name - :filter (lambda (&rest junk) - (cdr (custom-menu-create ',symbol))))) + ;; Fixme: sort out use of :filter in Emacs 21. + (if nil ;(string-match "XEmacs" emacs-version) + ;; We can delay it under XEmacs. + `(,name + :filter (lambda (&rest junk) + (cdr (custom-menu-create ',symbol)))) + ;; But we must create it now under Emacs. + (cons name (cdr (custom-menu-create symbol))))) ;;; The Custom Mode. @@ -3661,8 +3772,6 @@ The format is suitable for use with `easy-menu-define'." "Keymap for `custom-mode'.") (unless custom-mode-map - ;; This keymap should be dense, but a dense keymap would prevent inheriting - ;; "\r" bindings from the parent map. (setq custom-mode-map (make-sparse-keymap)) (set-keymap-parent custom-mode-map widget-keymap) (suppress-keymap custom-mode-map) @@ -3757,11 +3866,10 @@ if that value is non-nil." (set (make-local-variable 'widget-push-button-suffix) "") (set (make-local-variable 'widget-link-prefix) "") (set (make-local-variable 'widget-link-suffix) "")) + (make-local-hook 'widget-edit-functions) (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t) (run-hooks 'custom-mode-hook)) -(put 'custom-mode 'mode-class 'special) - (add-to-list 'debug-ignored-errors "^No user options have changed defaults in recent Emacs versions$") diff --git a/lisp/cus-face.el b/lisp/cus-face.el index a9290eb7294..b51ba8fee66 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -1,10 +1,10 @@ ;;; cus-face.el -- customization support for faces. ;; -;; Copyright (C) 1996, 1997, 1999 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2001 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen +;; Maintainer: FSF ;; Keywords: help, faces -;; Version: Emacs ;; This file is part of GNU Emacs. @@ -109,14 +109,13 @@ (choice :tag "Height" :help-echo "Face's font height." (const :tag "*" nil) - (integer :tag "Height in 1/10 pt") - (number :tag "Scale" 1.0)) + (integer :tag "Height in 1/10 pt")) (lambda (face value &optional frame) (set-face-attribute face frame :height (or value 'unspecified))) (lambda (face &optional frame) (let ((height (face-attribute face :height frame))) (if (eq height 'unspecified) nil height)))) - + (:weight (choice :tag "Weight" :help-echo "Font weight." @@ -279,33 +278,14 @@ (set-face-attribute face frame :stipple (or value 'unspecified))) (lambda (face &optional frame) (let ((value (face-attribute face :stipple frame))) - (if (eq value 'unspecified) nil value)))) - - (:inherit - (repeat :tag "Inherit" - :help-echo "List of faces to inherit attributes from." - (face :Tag "Face" default)) - (lambda (face value &optional frame) - (message "Setting to: <%s>" value) - (set-face-attribute face frame :inherit - (if (and (consp value) (null (cdr value))) - (car value) - value))) - (lambda (face &optional frame) - (let ((value (face-attribute face :inherit frame))) - (cond ((or (null value) (eq value 'unspecified)) - nil) - ((symbolp value) - (list value)) - (t - value)))))) + (if (eq value 'unspecified) nil value))))) "Alist of face attributes. The elements are of the form (KEY TYPE SET GET), where KEY is the name of the attribute, TYPE is a widget type for editing the attibute, SET is a function for setting the attribute value, and GET is a function -for getiing the attribute value. +for getting the attribute value. The SET function should take three arguments, the face to modify, the value of the attribute, and optionally the frame where the face should @@ -314,7 +294,6 @@ be changed. The GET function should take two arguments, the face to examine, and optionally the frame where the face should be examined.") - (defun custom-face-attributes-get (face frame) "For FACE on FRAME, return an alternating list describing its attributes. The list has the form (KEYWORD VALUE KEYWORD VALUE...). @@ -327,8 +306,7 @@ If FRAME is nil, use the global defaults for FACE." (let* ((attribute (car (car attrs))) (value (face-attribute face attribute frame))) (setq attrs (cdr attrs)) - (unless (or (eq value 'unspecified) - (and (null value) (memq attribute '(:inherit)))) + (unless (eq value 'unspecified) (setq plist (cons attribute (cons value plist)))))) plist)) @@ -337,36 +315,125 @@ If FRAME is nil, use the global defaults for FACE." ;;;###autoload (defun custom-set-faces (&rest args) "Initialize faces according to user preferences. +This asociates the setting with the USER theme. The arguments should be a list where each entry has the form: (FACE SPEC [NOW [COMMENT]]) -SPEC is stored as the saved value for FACE. +SPEC is stored as the saved value for FACE, as well as the value for the +user theme. The user theme is one of the default themes known to Emacs. +See `custom-known-themes' for more information on the known themes. +See `custom-theme-set-faces' for more information on the interplay +between themes and faces. +See `defface' for the format of SPEC. + +If NOW is present and non-nil, FACE is created now, according to SPEC. +COMMENT is a string comment about FACE." + (apply 'custom-theme-set-faces 'user args)) + +(defun custom-theme-set-faces (theme &rest args) + "Initialize faces for theme THEME. +The arguments should be a list where each entry has the form: + + (FACE SPEC [NOW [COMMENT]]) + +SPEC is stored as the saved value for FACE, as well as the value for the +user theme. The user theme is one of the default themes known to Emacs. +See `custom-known-themes' for more information on the known themes. +See `custom-theme-set-faces' for more information on the interplay +between themes and faces. +See `defface' for the format of SPEC. + If NOW is present and non-nil, FACE is created now, according to SPEC. COMMENT is a string comment about FACE. -See `defface' for the format of SPEC." - (while args - (let ((entry (car args))) - (if (listp entry) - (let ((face (nth 0 entry)) - (spec (nth 1 entry)) - (now (nth 2 entry)) - (comment (nth 3 entry))) - (put face 'saved-face spec) - (put face 'saved-face-comment comment) - (when now - (put face 'force-face t)) - (when (or now (facep face)) - (put face 'face-comment comment) - (make-empty-face face) - (face-spec-set face spec)) +Several properties of THEME and FACE are used in the process: + +If THEME property `theme-immediate' is non-nil, this is equivalent of +providing the NOW argument to all faces in the argument list: FACE is +created now. The only difference is FACE property `force-face': if NOW +is non-nil, FACE property force-face is set to the symbol `rogue', else +if THEME property theme-immediate is non-nil, FACE property force-face +is set to the symbol `immediate'. + +SPEC itself is saved in FACE property `saved-face' and it is stored in +FACE's list property `theme-face' \(using `custom-push-theme')." + (custom-check-theme theme) + (let ((immediate (get theme 'theme-immediate))) + (while args + (let ((entry (car args))) + (if (listp entry) + (let ((face (nth 0 entry)) + (spec (nth 1 entry)) + (now (nth 2 entry)) + (comment (nth 3 entry))) + (put face 'saved-face spec) + (put face 'saved-face-comment comment) + (custom-push-theme 'theme-face face theme 'set spec) + (when (or now immediate) + (put face 'force-face (if now 'rogue 'immediate))) + (when (or now immediate (facep face)) + (unless (facep face) + (make-empty-face face)) + (put face 'face-comment comment) + (face-spec-set face spec)) (setq args (cdr args))) ;; Old format, a plist of FACE SPEC pairs. (let ((face (nth 0 args)) (spec (nth 1 args))) - (put face 'saved-face spec)) - (setq args (cdr (cdr args))))))) + (put face 'saved-face spec) + (custom-push-theme 'theme-face face theme 'set spec)) + (setq args (cdr (cdr args)))))))) + +;;;###autoload +(defun custom-theme-face-value (face theme) + "Return spec of FACE in THEME if THEME modifies FACE. +Nil otherwise. The associations between theme and spec for FACE +is stored in FACE's property `theme-face'. The appropriate face +is retrieved using `custom-theme-value'." + ;; Returns car because the value is stored inside a one element list + (car-safe (custom-theme-value theme (get face 'theme-face)))) + +(defun custom-theme-reset-internal-face (face to-theme) + "Reset FACE to the value defined by TO-THEME. +If FACE is not defined in TO-THEME, reset FACE to the standard +value. See `custom-theme-face-value'. The standard value is +stored in SYMBOL's property `face-defface-spec' by `defface'." + (let ((spec (custom-theme-face-value face to-theme)) + was-in-theme) + (setq was-in-theme spec) + (setq spec (or spec (get face 'face-defface-spec))) + (when spec + (put face 'save-face was-in-theme) + (when (or (get face 'force-face) (facep face)) + (unless (facep face) + (make-empty-face face)) + (face-spec-set face spec))) + spec)) + +;;;###autoload +(defun custom-theme-reset-faces (theme &rest args) + "Reset the value of the face to values previously defined. +Associate this setting with THEME. + +ARGS is a list of lists of the form + + (FACE TO-THEME) + +This means reset FACE to its value in TO-THEME." + (custom-check-theme theme) + (mapcar '(lambda (arg) + (apply 'custom-theme-reset-internal-face arg) + (custom-push-theme 'theme-face (car arg) theme 'reset (cadr arg))) + args)) + +;;;###autoload +(defun custom-reset-faces (&rest args) + "Reset the value of the face to values previously saved. +This is the setting assosiated the `user' theme. + +ARGS is defined as for `custom-theme-reset-faces'" + (apply 'custom-theme-reset-faces 'user args)) ;;; The End. diff --git a/lisp/custom.el b/lisp/custom.el new file mode 100644 index 00000000000..1b62aa92a6a --- /dev/null +++ b/lisp/custom.el @@ -0,0 +1,881 @@ +;;; custom.el -- Tools for declaring and initializing options. +;; +;; Copyright (C) 1996, 1997, 1999, 2001 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Maintainer: FSF +;; Keywords: help, faces + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; This file only contain the code needed to declare and initialize +;; user options. The code to customize options is autoloaded from +;; `cus-edit.el' and is documented in the Emacs Lisp Reference manual. + +;; The code implementing face declarations is in `cus-face.el' + +;;; Code: + +(require 'widget) + +(defvar custom-define-hook nil + ;; Customize information for this option is in `cus-edit.el'. + "Hook called after defining each customize option.") + +;;; The `defcustom' Macro. + +(defun custom-initialize-default (symbol value) + "Initialize SYMBOL with VALUE. +This will do nothing if symbol already has a default binding. +Otherwise, if symbol has a `saved-value' property, it will evaluate +the car of that and used as the default binding for symbol. +Otherwise, VALUE will be evaluated and used as the default binding for +symbol." + (unless (default-boundp symbol) + ;; Use the saved value if it exists, otherwise the standard setting. + (set-default symbol (if (get symbol 'saved-value) + (eval (car (get symbol 'saved-value))) + (eval value))))) + +(defun custom-initialize-set (symbol value) + "Initialize SYMBOL based on VALUE. +If the symbol doesn't have a default binding already, +then set it using its `:set' function (or `set-default' if it has none). +The value is either the value in the symbol's `saved-value' property, +if any, or VALUE." + (unless (default-boundp symbol) + (funcall (or (get symbol 'custom-set) 'set-default) + symbol + (if (get symbol 'saved-value) + (eval (car (get symbol 'saved-value))) + (eval value))))) + +(defun custom-initialize-reset (symbol value) + "Initialize SYMBOL based on VALUE. +Set the symbol, using its `:set' function (or `set-default' if it has none). +The value is either the symbol's current value + \(as obtained using the `:get' function), if any, +or the value in the symbol's `saved-value' property if any, +or (last of all) VALUE." + (funcall (or (get symbol 'custom-set) 'set-default) + symbol + (cond ((default-boundp symbol) + (funcall (or (get symbol 'custom-get) 'default-value) + symbol)) + ((get symbol 'saved-value) + (eval (car (get symbol 'saved-value)))) + (t + (eval value))))) + +(defun custom-initialize-changed (symbol value) + "Initialize SYMBOL with VALUE. +Like `custom-initialize-reset', but only use the `:set' function if changing +the standard setting. +For the standard setting, use the `set-default'." + (cond ((default-boundp symbol) + (funcall (or (get symbol 'custom-set) 'set-default) + symbol + (funcall (or (get symbol 'custom-get) 'default-value) + symbol))) + ((get symbol 'saved-value) + (funcall (or (get symbol 'custom-set) 'set-default) + symbol + (eval (car (get symbol 'saved-value))))) + (t + (set-default symbol (eval value))))) + +(defun custom-declare-variable (symbol default doc &rest args) + "Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments. +DEFAULT should be an expression to evaluate to compute the default value, +not the default value itself. + +DEFAULT is stored as SYMBOL's value in the standard theme. See +`custom-known-themes' for a list of known themes. For backwards +compatibility, DEFAULT is also stored in SYMBOL's property +`standard-value'. At the same time, SYMBOL's property `force-value' is +set to nil, as the value is no longer rogue." + ;; Remember the standard setting. The value should be in the standard + ;; theme, not in this property. However, his would require changeing + ;; the C source of defvar and others as well... + (put symbol 'standard-value (list default)) + ;; Maybe this option was rogue in an earlier version. It no longer is. + (when (get symbol 'force-value) + (put symbol 'force-value nil)) + (when doc + (put symbol 'variable-documentation doc)) + (let ((initialize 'custom-initialize-reset) + (requests nil)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :initialize) + (setq initialize value)) + ((eq keyword :set) + (put symbol 'custom-set value)) + ((eq keyword :get) + (put symbol 'custom-get value)) + ((eq keyword :require) + (setq requests (cons value requests))) + ((eq keyword :type) + (put symbol 'custom-type (purecopy value))) + ((eq keyword :options) + (if (get symbol 'custom-options) + ;; Slow safe code to avoid duplicates. + (mapcar (lambda (option) + (custom-add-option symbol option)) + value) + ;; Fast code for the common case. + (put symbol 'custom-options (copy-sequence value)))) + (t + (custom-handle-keyword symbol keyword value + 'custom-variable)))))) + (put symbol 'custom-requests requests) + ;; Do the actual initialization. + (funcall initialize symbol default)) + (setq current-load-list (cons symbol current-load-list)) + (run-hooks 'custom-define-hook) + symbol) + +(defmacro defcustom (symbol value doc &rest args) + "Declare SYMBOL as a customizable variable that defaults to VALUE. +DOC is the variable documentation. + +Neither SYMBOL nor VALUE needs to be quoted. +If SYMBOL is not already bound, initialize it to VALUE. +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following keywords are meaningful: + +:type VALUE should be a widget type for editing the symbols value. + The default is `sexp'. +:options VALUE should be a list of valid members of the widget type. +:group VALUE should be a customization group. + Add SYMBOL to that group. +:initialize + VALUE should be a function used to initialize the + variable. It takes two arguments, the symbol and value + given in the `defcustom' call. The default is + `custom-initialize-default' +:set VALUE should be a function to set the value of the symbol. + It takes two arguments, the symbol to set and the value to + give it. The default choice of function is `custom-set-default'. +:get VALUE should be a function to extract the value of symbol. + The function takes one argument, a symbol, and should return + the current value for that symbol. The default choice of function + is `custom-default-value'. +:require + VALUE should be a feature symbol. If you save a value + for this option, then when your `.emacs' file loads the value, + it does (require VALUE) first. +:version + VALUE should be a string specifying that the variable was + first introduced, or its default value was changed, in Emacs + version VERSION. + +The actual work is done in function `custom-declare-variable'. + +Read the section about customization in the Emacs Lisp manual for more +information." + ;; It is better not to use backquote in this file, + ;; because that makes a bootstrapping problem + ;; if you need to recompile all the Lisp files using interpreted code. + (nconc (list 'custom-declare-variable + (list 'quote symbol) + (list 'quote value) + doc) + args)) + +;;; The `defface' Macro. + +(defmacro defface (face spec doc &rest args) + "Declare FACE as a customizable face that defaults to SPEC. +FACE does not need to be quoted. + +Third argument DOC is the face documentation. + +If FACE has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to SPEC. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORDs are defined: + +:group VALUE should be a customization group. + Add FACE to that group. + +SPEC should be an alist of the form ((DISPLAY ATTS)...). + +The first element of SPEC where the DISPLAY matches the frame +is the one that takes effect in that frame. The ATTRs in this +element take effect; the other elements are ignored, on that frame. + +ATTS is a list of face attributes followed by their values: + (ATTR VALUE ATTR VALUE...) + +The possible attributes are `:family', `:width', `:height', `:weight', +`:slant', `:underline', `:overline', `:strike-through', `:box', +`:foreground', `:background', `:stipple', and `:inverse-video'. + +DISPLAY can either be the symbol t, which will match all frames, or an +alist of the form \((REQ ITEM...)...). For the DISPLAY to match a +FRAME, the REQ property of the frame must match one of the ITEM. The +following REQ are defined: + +`type' (the value of `window-system') + Under X, in addition to the values `window-system' can take, + `motif', `lucid' and `x-toolkit' are allowed, and match when + the Motif toolkit, Lucid toolkit, or any X toolkit is in use. + +`class' (the frame's color support) + Should be one of `color', `grayscale', or `mono'. + +`background' (what color is used for the background text) + Should be one of `light' or `dark'. + +Read the section about customization in the Emacs Lisp manual for more +information." + ;; It is better not to use backquote in this file, + ;; because that makes a bootstrapping problem + ;; if you need to recompile all the Lisp files using interpreted code. + (nconc (list 'custom-declare-face (list 'quote face) spec doc) args)) + +;;; The `defgroup' Macro. + +(defun custom-declare-group (symbol members doc &rest args) + "Like `defgroup', but SYMBOL is evaluated as a normal argument." + (while members + (apply 'custom-add-to-group symbol (car members)) + (setq members (cdr members))) + (put symbol 'custom-group (nconc members (get symbol 'custom-group))) + (when doc + ;; This text doesn't get into DOC. + (put symbol 'group-documentation (purecopy doc))) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :prefix) + (put symbol 'custom-prefix value)) + (t + (custom-handle-keyword symbol keyword value + 'custom-group)))))) + (run-hooks 'custom-define-hook) + symbol) + +(defmacro defgroup (symbol members doc &rest args) + "Declare SYMBOL as a customization group containing MEMBERS. +SYMBOL does not need to be quoted. + +Third arg DOC is the group documentation. + +MEMBERS should be an alist of the form ((NAME WIDGET)...) where +NAME is a symbol and WIDGET is a widget for editing that symbol. +Useful widgets are `custom-variable' for editing variables, +`custom-face' for edit faces, and `custom-group' for editing groups. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORDs are defined: + +:group VALUE should be a customization group. + Add SYMBOL to that group. + +:version VALUE should be a string specifying that the group was introduced + in Emacs version VERSION. + +Read the section about customization in the Emacs Lisp manual for more +information." + ;; It is better not to use backquote in this file, + ;; because that makes a bootstrapping problem + ;; if you need to recompile all the Lisp files using interpreted code. + (nconc (list 'custom-declare-group (list 'quote symbol) members doc) args)) + +(defun custom-add-to-group (group option widget) + "To existing GROUP add a new OPTION of type WIDGET. +If there already is an entry for that option, overwrite it." + (let* ((members (get group 'custom-group)) + (old (assq option members))) + (if old + (setcar (cdr old) widget) + (put group 'custom-group (nconc members (list (list option widget))))))) + +;;; Properties. + +(defun custom-handle-all-keywords (symbol args type) + "For customization option SYMBOL, handle keyword arguments ARGS. +Third argument TYPE is the custom option type." + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (custom-handle-keyword symbol keyword value type))))) + +(defun custom-handle-keyword (symbol keyword value type) + "For customization option SYMBOL, handle KEYWORD with VALUE. +Fourth argument TYPE is the custom option type." + (if purify-flag + (setq value (purecopy value))) + (cond ((eq keyword :group) + (custom-add-to-group value symbol type)) + ((eq keyword :version) + (custom-add-version symbol value)) + ((eq keyword :link) + (custom-add-link symbol value)) + ((eq keyword :load) + (custom-add-load symbol value)) + ((eq keyword :tag) + (put symbol 'custom-tag value)) + ((eq keyword :set-after) + (custom-add-dependencies symbol value)) + (t + (error "Unknown keyword %s" keyword)))) + +(defun custom-add-dependencies (symbol value) + "To the custom option SYMBOL, add dependencies specified by VALUE. +VALUE should be a list of symbols. For each symbol in that list, +this specifies that SYMBOL should be set after the specified symbol, if +both appear in constructs like `custom-set-variables'." + (unless (listp value) + (error "Invalid custom dependency `%s'" value)) + (let* ((deps (get symbol 'custom-dependencies)) + (new-deps deps)) + (while value + (let ((dep (car value))) + (unless (symbolp dep) + (error "Invalid custom dependency `%s'" dep)) + (unless (memq dep new-deps) + (setq new-deps (cons dep new-deps))) + (setq value (cdr value)))) + (unless (eq deps new-deps) + (put symbol 'custom-dependencies new-deps)))) + +(defun custom-add-option (symbol option) + "To the variable SYMBOL add OPTION. + +If SYMBOL is a hook variable, OPTION should be a hook member. +For other types variables, the effect is undefined." + (let ((options (get symbol 'custom-options))) + (unless (member option options) + (put symbol 'custom-options (cons option options))))) + +(defun custom-add-link (symbol widget) + "To the custom option SYMBOL add the link WIDGET." + (let ((links (get symbol 'custom-links))) + (unless (member widget links) + (put symbol 'custom-links (cons (purecopy widget) links))))) + +(defun custom-add-version (symbol version) + "To the custom option SYMBOL add the version VERSION." + (put symbol 'custom-version (purecopy version))) + +(defun custom-add-load (symbol load) + "To the custom option SYMBOL add the dependency LOAD. +LOAD should be either a library file name, or a feature name." + (let ((loads (get symbol 'custom-loads))) + (unless (member load loads) + (put symbol 'custom-loads (cons (purecopy load) loads))))) + +;;; The `deftheme' macro + +(defvar custom-known-themes '(user standard) + "Themes that have been defthemed. +The default value is the list (user standard). The standard theme +contains the Emacs standard settings from the original elisp files. The +user theme contains all the the settings the user customized and saved. +Additional themes declared with the `deftheme' macro will be added to +the front of this list.") + +(defun custom-declare-theme (theme feature &optional doc &rest args) + "Like `deftheme', but THEME is evaluated as a normal argument. +FEATURE is the feature this theme provides. This symbol is created +from THEME by `custom-make-theme-feature'." + (add-to-list 'custom-known-themes theme) + (put theme 'theme-feature feature) + (when doc + (put theme 'theme-documentation doc)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :short-description) + (put theme 'theme-short-description short-description)) + ((eq keyword :immediate) + (put theme 'theme-immediate immediate)) + ((eq keyword :variable-set-string) + (put theme 'theme-variable-set-string variable-set-string)) + ((eq keyword :variable-reset-string) + (put theme 'theme-variable-reset-string variable-reset-string)) + ((eq keyword :face-set-string) + (put theme 'theme-face-set-string face-set-string)) + ((eq keyword :face-reset-string) + (put theme 'theme-face-reset-string face-reset-string))))))) + +(defmacro deftheme (theme &optional doc &rest args) + "Declare THEME. + +The optional argument DOC is a doc string describing the the theme. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:short-description + VALUE is a short (one line) description of the theme. If not + given DOC is used. +:immediate + If VALUE is non-nil, variables set in this theme are bound + immediately when loading the theme. +:variable-set-string + VALUE is a string used to indicate that a variable takes its + setting from this theme. It is passed to FORMAT with the name + of the theme as an additional argument. If not given, a + generic description is used. +:variable-reset-string + VALUE is a string used in the case a variable has been forced + to its value in this theme. It is passed to FORMAT with the + name of the theme as an additional argument. If not given, a + generic description is used. +:face-set-string + VALUE is a string used to indicate that a face takes its + setting from this theme. It is passed to FORMAT with the name + of the theme as an additional argument. If not given, a + generic description is used. +:face-reset-string + VALUE is a string used in the case a face has been forced to + its value in this theme. It is passed to FORMAT with the name + of the theme as an additional argument. If not given, a + generic description is used. + +Any theme foo should be defined in a file called foo-theme.el or +foo-theme.elc; see `custom-make-theme-feature' for more information." + (let ((feature (custom-make-theme-feature theme))) + ;; It is better not to use backquote in this file, + ;; because that makes a bootstrapping problem + ;; if you need to recompile all the Lisp files using interpreted code. + (nconc (list 'custom-declare-theme + (list 'quote theme) + (list 'quote feature) + doc) args))) + +(defun custom-make-theme-feature (theme) + "Given a symbol THEME, create a new symbol by appending \"-theme\" +to the name of symbol THEME. This new symbol will be stored in the +theme-feature property of THEME. This is the symbol a theme will +provide once it is defined using `provide-theme', and it is the symbol +other themes can require using `require-theme' when they are being +installed. + +This allows for a file-name convention: Every theme X has a property +provide-theme which contains the value \"X-theme\". Calling +\(require-theme X) will attempt to load files \"X-theme.el\" or +\"X-theme.elc\"." + (intern (concat (symbol-name theme) "-theme"))) + +(defsubst custom-theme-p (theme) + "Non-nil when THEME has been defined." + (memq theme custom-known-themes)) + +(defsubst custom-check-theme (theme) + "Check whether THEME is valid and signal an error if it is not." + (unless (custom-theme-p theme) + (error "Unknown theme `%s'" theme))) + +;;; Initializing. + +(defun custom-push-theme (prop symbol theme mode value) + "Add (THEME MODE VALUE) to the list property PROP of SYMBOL. + +MODE can be either the symbol `set' or the symbol `reset'. If it is the +symbol `set', then VALUE is the value to use. If it is the symbol +`reset', then VALUE is the mode to query instead. + +In the following example for the variable goto-address-url-face, the +theme subtle-hacker uses the same value for the variable as the theme +gnome2: + + \((standard set bold) + \(gnome2 set info-xref) + \(jonadab set underline) + \(subtle-hacker reset gnome2)) + +If the car of the list is already a list with car THEME, the +car of the list is discarded. + +If a value has been stored for themes A B and C, and a new value +is to be stored for theme C, then the old value of C is discarded. +If a new value is to be stored for theme B, however, the old value +of B is not discarded because B is not the car of the list. + +For variables, list property PROP is `theme-value'. +For faces, list property PROP is `theme-face'. +This is used in `custom-do-theme-reset', for example. + +The list looks the same in any case; the examples shows a possible +value of the theme-face property for the region face: + + \((gnome2 set ((t (:foreground \"cyan\" :background \"dark cyan\")))) + \(standard set ((((class color) (background dark)) + \(:background \"blue\")) + \(t (:background \"gray\"))))) + +In this case, the values for the standard and the gnome2 theme were +stored. The user has not customized the face; had he done that, +the list would contain an entry for the user theme, too. +See `custom-known-themes' for a list of known themes." + (let ((old (get symbol prop))) + (if (eq (car-safe (car-safe old)) theme) + (setq old (cdr old))) + (put symbol prop (cons (list theme mode value) old)))) + +(defvar custom-local-buffer nil + "Non-nil, in a Customization buffer, means customize a specific buffer. +If this variable is non-nil, it should be a buffer, +and it means customize the local bindings of that buffer. +This variable is a permanent local, and it normally has a local binding +in every Customization buffer.") +(put 'custom-local-buffer 'permanent-local t) + +(defun custom-set-variables (&rest args) + "Initialize variables according to user preferences. +The settings are registered as theme user. +The arguments should be a list where each entry has the form: + + (SYMBOL VALUE [NOW [REQUEST [COMMENT]]]) + +The unevaluated VALUE is stored as the saved value for SYMBOL. +If NOW is present and non-nil, VALUE is also evaluated and bound as +the default value for the SYMBOL. + +REQUEST is a list of features we must 'require for SYMBOL. +COMMENT is a comment string about SYMBOL." + (apply 'custom-theme-set-variables 'user args)) + +(defun custom-theme-set-variables (theme &rest args) + "Initialize variables according to settings specified by args. +Records the settings as belonging to THEME. + +The arguments should be a list where each entry has the form: + + (SYMBOL VALUE [NOW [REQUEST [COMMENT]]]) + +The unevaluated VALUE is stored as the saved value for SYMBOL. +If NOW is present and non-nil, VALUE is also evaluated and bound as +the default value for the SYMBOL. + +REQUEST is a list of features we must 'require for SYMBOL. +COMMENT is a comment string about SYMBOL. + +Several properties of THEME and SYMBOL are used in the process: + +If THEME property `theme-immediate' is non-nil, this is equivalent of +providing the NOW argument to all symbols in the argument list: SYMBOL +is bound to the evaluated VALUE. The only difference is SYMBOL property +`force-value': if NOW is non-nil, SYMBOL property force-value is set to +the symbol `rogue', else if THEME property theme-immediate is non-nil, +FACE property force-face is set to the symbol `immediate'. + +VALUE itself is saved unevaluated as SYMBOL property `saved-value' and +in SYMBOL's list property `theme-value' \(using `custom-push-theme')." + (custom-check-theme theme) + (let ((immediate (get theme 'theme-immediate))) + (setq args + (sort args + (lambda (a1 a2) + (let* ((sym1 (car a1)) + (sym2 (car a2)) + (1-then-2 (memq sym1 (get sym2 'custom-dependencies))) + (2-then-1 (memq sym2 (get sym1 'custom-dependencies)))) + (cond ((and 1-then-2 2-then-1) + (error "Circular custom dependency between `%s' and `%s'" + sym1 sym2)) + (2-then-1 nil) + (t t)))))) + (while args + (let ((entry (car args))) + (if (listp entry) + (let* ((symbol (nth 0 entry)) + (value (nth 1 entry)) + (now (nth 2 entry)) + (requests (nth 3 entry)) + (comment (nth 4 entry)) + (set (or (get symbol 'custom-set) 'set-default))) + (when requests + (put symbol 'custom-requests requests) + (mapcar 'require requests)) + (put symbol 'saved-value (list value)) + (put symbol 'saved-variable-comment comment) + (custom-push-theme 'theme-value symbol theme 'set value) + ;; Allow for errors in the case where the setter has + ;; changed between versions, say. + (condition-case nil + (cond ((or now immediate) + ;; Rogue variable, set it now. + (put symbol 'force-value (if now 'rogue 'immediate)) + (funcall set symbol (eval value))) + ((default-boundp symbol) + ;; Something already set this, overwrite it. + (funcall set symbol (eval value)))) + (error nil)) + (setq args (cdr args)) + (and (or now (default-boundp symbol)) + (put symbol 'variable-comment comment))) + ;; Old format, a plist of SYMBOL VALUE pairs. + (message "Warning: old format `custom-set-variables'") + (ding) + (sit-for 2) + (let ((symbol (nth 0 args)) + (value (nth 1 args))) + (put symbol 'saved-value (list value)) + (custom-push-theme 'theme-value symbol theme 'set value)) + (setq args (cdr (cdr args)))))))) + +;; FIXME: This function is never used? +(defun custom-set-default (variable value) + "Default :set function for a customizable variable. +Normally, this sets the default value of VARIABLE to VALUE, +but if `custom-local-buffer' is non-nil, +this sets the local binding in that buffer instead." + (if custom-local-buffer + (with-current-buffer custom-local-buffer + (set variable value)) + (set-default variable value))) + +;;; Theme Manipulation + +(defvar custom-loaded-themes nil + "Themes in the order they are loaded.") + +(defun custom-theme-loaded-p (theme) + "Return non-nil when THEME has been loaded." + (memq theme custom-loaded-themes)) + +(defun provide-theme (theme) + "Indicate that this file provides THEME. +Add THEME to `custom-loaded-themes' and `provide' whatever +is stored in THEME's property `theme-feature'. + +Usually the theme-feature property contains a symbol created +by `custom-make-theme-feature'." + (custom-check-theme theme) + (provide (get theme 'theme-feature)) + (setq custom-loaded-themes (nconc (list theme) custom-loaded-themes))) + +(defun require-theme (theme) + "Try to load a theme by requiring its feature. +THEME's feature is stored in the theme-feature property. + +Usually the theme-feature property contains a symbol created +by `custom-make-theme-feature'." + ;; Note we do no check for validity of the theme here. + ;; This allows to pull in themes by a file-name convention + (require (or (get theme 'theme-feature) + (custom-make-theme-feature theme)))) + +(defun custom-remove-theme (spec-alist theme) + "Detelete all elements from SPEC-ALIST whose car is THEME." + (let ((elt (assoc theme spec-alist))) + (while elt + (setq spec-alist (delete elt spec-alist) + elt (assoc theme spec-alist)))) + spec-alist) + +(defun custom-do-theme-reset (theme) + "Undo all settings defined by THEME. + +Variables remain unchanged if their property `theme-value' does not +contain a value for THEME. Faces remain unchanged if their property +`theme-face' does not contain a value for THEME. In either case, all +settings for THEME are removed from the property and the variable or +face is set to the `user' theme. See `custom-known-themes' for a list +of known themes." + (let (spec-list) + (mapatoms (lambda (symbol) + ;; This works even if symbol is both a variable and a + ;; face. + (setq spec-list (get symbol 'theme-value)) + (when spec-list + (put symbol 'theme-value (custom-remove-theme spec-list theme)) + (custom-theme-reset-internal symbol 'user)) + (setq spec-list (get symbol 'theme-face)) + (when spec-list + (put symbol 'theme-face (custom-remove-theme spec-list theme)) + (custom-theme-reset-internal-face symbol 'user)))))) + +(defun custom-theme-load-themes (by-theme &rest body) + "Load the themes specified by BODY and record them as required by +theme BY-THEME. BODY is a sequence of either + +THEME + BY-THEME requires THEME +\(reset THEME) + Undo all the settings made by THEME +\(hidden THEME) + Require THEME but hide it from the user + +All the themes loaded for BY-THEME are recorded in BY-THEME's property +`theme-loads-themes'. Any theme loaded with the hidden predicate will +be given the property `theme-hidden' unless it has been loaded before. +Wether a theme has been loaded before is determined by the function +`custom-theme-loaded-p'." + (custom-check-theme by-theme) + (let ((theme) + (themes-loaded (get by-theme 'theme-loads-themes))) + (while theme + (setq theme (car body) + body (cdr body)) + (cond ((and (consp theme) (eq (car theme) 'reset)) + (custom-do-theme-reset (cadr theme))) + ((and (consp theme) (eq (car theme) 'hidden)) + (require-theme (cadr theme)) + (unless (custom-theme-loaded-p (cadr theme)) + (put (cadr theme) 'theme-hidden t))) + (t + (require-theme theme) + (put theme 'theme-hidden nil))) + (setq themes-loaded (nconc (list theme) themes-loaded))) + (put by-theme 'theme-loads-themes themes-loaded))) + +(defun custom-load-themes (&rest body) + "Load themes for the USER theme as specified by BODY. + +See `custom-theme-load-themes' for more information on BODY." + (apply 'custom-theme-load-themes 'user body)) + +; (defsubst copy-upto-last (elt list) +; "Copy all the elements of the list upto the last occurence of elt" +; ;; Is it faster to do more work in C than to do less in elisp? +; (nreverse (cdr (member elt (reverse list))))) + +(defun custom-theme-value (theme theme-spec-list) + "Determine the value for THEME defined by THEME-SPEC-LIST. +Returns a list with the original value if found. Nil otherwise. + +THEME-SPEC-LIST is an alist with themes as its key. As new themes are +installed, these are added to the front of THEME-SPEC-LIST. +Each element has the form + + \(THEME MODE VALUE) + +MODE is either the symbol `set' or the symbol `reset'. See +`custom-push-theme' for more information on the format of +THEME-SPEC-LIST." + ;; Note we do _NOT_ signal an error if the theme is unknown + ;; it might have gone away without the user knowing. + (let ((value (cdr (assoc theme theme-spec-list)))) + (if value + (if (eq (car value) 'set) + (cdr value) + (custom-theme-value (cadr value) theme-spec-list))))) + +(defun custom-theme-variable-value (variable theme) + "Return (list value) value of VARIABLE in THEME. +If THEME does not define a value for VARIABLE, return nil. The value +definitions per theme are stored in VARIABLE's property `theme-value'. +The actual work is done by function `custom-theme-value', which see. +See `custom-push-theme' for more information on how these definitions +are stored." + (custom-theme-value theme (get variable 'theme-value))) + +(defun custom-theme-reset-internal (symbol to-theme) + "Reset SYMBOL to the value defined by TO-THEME. +If SYMBOL is not defined in TO-THEME, reset SYMBOL to the standard +value. See `custom-theme-variable-value'. The standard value is +stored in SYMBOL's property `standard-value'." + (let ((value (custom-theme-variable-value symbol to-theme)) + was-in-theme) + (setq was-in-theme value) + (setq value (or value (get symbol 'standard-value))) + (when value + (put symbol 'saved-value was-in-theme) + (if (or (get 'force-value symbol) (default-boundp symbol)) + (funcall (or (get symbol 'custom-set) 'set-default) symbol + (eval (car value))))) + value)) + +(defun custom-theme-reset-variables (theme &rest args) + "Reset the value of the variables to values previously defined. +Associate this setting with THEME. + +ARGS is a list of lists of the form + + (VARIABLE TO-THEME) + +This means reset VARIABLE to its value in TO-THEME." + (custom-check-theme theme) + (mapcar '(lambda (arg) + (apply 'custom-theme-reset-internal arg) + (custom-push-theme 'theme-value (car arg) theme 'reset (cadr arg))) + args)) + +(defun custom-reset-variables (&rest args) + "Reset the value of the variables to values previously saved. +This is the setting associated the `user' theme. + +ARGS is a list of lists of the form + + (VARIABLE TO-THEME) + +This means reset VARIABLE to its value in TO-THEME." + (apply 'custom-theme-reset-variables 'user args)) + +;;; The End. + +;; Process the defcustoms for variables loaded before this file. +(while custom-declare-variable-list + (apply 'custom-declare-variable (car custom-declare-variable-list)) + (setq custom-declare-variable-list (cdr custom-declare-variable-list))) + +(provide 'custom) + +;;; custom.el ends here -- 2.39.5