;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
(when (get symbol 'force-value)
(put symbol 'force-value nil))
(when doc
- (put symbol 'variable-documentation doc))
+ (if (keywordp doc)
+ (error "Doc string is missing")
+ (put symbol 'variable-documentation doc)))
(let ((initialize 'custom-initialize-reset)
(requests nil))
(unless (memq :group args)
See Info node `(elisp) Customization' in the Emacs Lisp manual
for more information."
- (declare (doc-string 3))
+ (declare (doc-string 3) (debug (name body)))
;; 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.
(setting (assq theme old)) ; '(theme value)
(theme-settings ; '(prop symbol theme value)
(get theme 'theme-settings)))
- (if (eq mode 'reset)
- ;; Remove a setting.
- (when setting
- (let (res)
- (dolist (theme-setting theme-settings)
- (if (and (eq (car theme-setting) prop)
- (eq (cadr theme-setting) symbol))
- (setq res theme-setting)))
- (put theme 'theme-settings (delq res theme-settings)))
- (put symbol prop (delq setting old)))
- (if setting
- ;; Alter an existing setting.
- (let (res)
- (dolist (theme-setting theme-settings)
- (if (and (eq (car theme-setting) prop)
- (eq (cadr theme-setting) symbol))
- (setq res theme-setting)))
- (put theme 'theme-settings
- (cons (list prop symbol theme value)
- (delq res theme-settings)))
- (setcar (cdr setting) value))
- ;; Add a new setting.
+ (cond
+ ;; Remove a setting:
+ ((eq mode 'reset)
+ (when setting
+ (let (res)
+ (dolist (theme-setting theme-settings)
+ (if (and (eq (car theme-setting) prop)
+ (eq (cadr theme-setting) symbol))
+ (setq res theme-setting)))
+ (put theme 'theme-settings (delq res theme-settings)))
+ (put symbol prop (delq setting old))))
+ ;; Alter an existing setting:
+ (setting
+ (let (res)
+ (dolist (theme-setting theme-settings)
+ (if (and (eq (car theme-setting) prop)
+ (eq (cadr theme-setting) symbol))
+ (setq res theme-setting)))
+ (put theme 'theme-settings
+ (cons (list prop symbol theme value)
+ (delq res theme-settings)))
+ (setcar (cdr setting) value)))
+ ;; Add a new setting:
+ (t
+ (unless old
;; If the user changed the value outside of Customize, we
;; first save the current value to a fake theme, `changed'.
;; This ensures that the user-set value comes back if the
;; theme is later disabled.
- (if (null old)
- (if (and (eq prop 'theme-value)
- (boundp symbol))
- (let ((sv (get symbol 'standard-value)))
- (unless (and sv
- (equal (eval (car sv)) (symbol-value symbol)))
- (setq old (list (list 'changed (symbol-value symbol))))))
- (if (and (facep symbol)
- (not (face-spec-match-p symbol (get symbol 'face-defface-spec))))
- (setq old (list (list 'changed (list
- (append '(t) (custom-face-attributes-get symbol nil)))))))))
- (put symbol prop (cons (list theme value) old))
- (put theme 'theme-settings
- (cons (list prop symbol theme value)
- theme-settings))))))
-
+ (cond ((and (eq prop 'theme-value)
+ (boundp symbol))
+ (let ((sv (get symbol 'standard-value)))
+ (unless (and sv
+ (equal (eval (car sv)) (symbol-value symbol)))
+ (setq old (list (list 'changed (symbol-value symbol)))))))
+ ((and (facep symbol)
+ (not (face-attr-match-p
+ symbol
+ (custom-fix-face-spec
+ (face-spec-choose
+ (get symbol 'face-defface-spec))))))
+ (setq old `((changed
+ (,(append '(t) (custom-face-attributes-get
+ symbol nil)))))))))
+ (put symbol prop (cons (list theme value) old))
+ (put theme 'theme-settings
+ (cons (list prop symbol theme value) theme-settings))))))
+
+(defun custom-fix-face-spec (spec)
+ "Convert face SPEC, replacing obsolete :bold and :italic attributes.
+Also change :reverse-video to :inverse-video."
+ (when (listp spec)
+ (if (or (memq :bold spec)
+ (memq :italic spec)
+ (memq :inverse-video spec))
+ (let (result)
+ (while spec
+ (let ((key (car spec))
+ (val (car (cdr spec))))
+ (cond ((eq key :italic)
+ (push :slant result)
+ (push (if val 'italic 'normal) result))
+ ((eq key :bold)
+ (push :weight result)
+ (push (if val 'bold 'normal) result))
+ ((eq key :reverse-video)
+ (push :inverse-video result)
+ (push val result))
+ (t
+ (push key result)
+ (push val result))))
+ (setq spec (cddr spec)))
+ (nreverse result))
+ spec)))
\f
(defun custom-set-variables (&rest args)
"Install user customizations of variable values specified in ARGS.
EXP 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)
-
+
;; Process all the needed autoloads before anything else, so that the
;; subsequent code has all the info it needs (e.g. which var corresponds
;; to a minor mode), regardless of the ordering of the variables.
(t (or (nth 3 a2)
(eq (get sym2 'custom-set)
'custom-set-minor-mode))))))))
- (while args
- (let ((entry (car args)))
- (if (listp entry)
- (let* ((symbol (indirect-variable (nth 0 entry)))
- (value (nth 1 entry))
- (now (nth 2 entry))
- (requests (nth 3 entry))
- (comment (nth 4 entry))
- set)
- (when requests
- (put symbol 'custom-requests requests)
- (mapc 'require requests))
- (setq set (or (get symbol 'custom-set) 'custom-set-default))
- (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, but let the user know.
- (condition-case data
- (cond (now
- ;; Rogue variable, set it now.
- (put symbol 'force-value t)
- (funcall set symbol (eval value)))
- ((default-boundp symbol)
- ;; Something already set this, overwrite it.
- (funcall set symbol (eval value))))
- (error
- (message "Error setting %s: %s" symbol data)))
- (setq args (cdr args))
- (and (or now (default-boundp symbol))
- (put symbol 'variable-comment comment)))
- ;; I believe this is dead-code, because the `sort' code above would
- ;; have burped before we could get here. --Stef
- ;; Old format, a plist of SYMBOL VALUE pairs.
- (message "Warning: old format `custom-set-variables'")
- (ding)
- (sit-for 2)
- (let ((symbol (indirect-variable (nth 0 args)))
- (value (nth 1 args)))
+
+ (dolist (entry args)
+ (unless (listp entry)
+ (error "Incompatible Custom theme spec"))
+ (let* ((symbol (indirect-variable (nth 0 entry)))
+ (value (nth 1 entry)))
+ (custom-push-theme 'theme-value symbol theme 'set value)
+ (unless custom--inhibit-theme-enable
+ ;; Now set the variable.
+ (let* ((now (nth 2 entry))
+ (requests (nth 3 entry))
+ (comment (nth 4 entry))
+ set)
+ (when requests
+ (put symbol 'custom-requests requests)
+ (mapc 'require requests))
+ (setq set (or (get symbol 'custom-set) 'custom-set-default))
(put symbol 'saved-value (list value))
- (custom-push-theme 'theme-value symbol theme 'set value))
- (setq args (cdr (cdr args)))))))
+ (put symbol 'saved-variable-comment comment)
+ ;; Allow for errors in the case where the setter has
+ ;; changed between versions, say, but let the user know.
+ (condition-case data
+ (cond (now
+ ;; Rogue variable, set it now.
+ (put symbol 'force-value t)
+ (funcall set symbol (eval value)))
+ ((default-boundp symbol)
+ ;; Something already set this, overwrite it.
+ (funcall set symbol (eval value))))
+ (error
+ (message "Error setting %s: %s" symbol data)))
+ (and (or now (default-boundp symbol))
+ (put symbol 'variable-comment comment)))))))
\f
;;; Defining themes.
-;; A theme file should be named `THEME-theme.el' (where THEME is the theme
-;; name), and found in either `custom-theme-directory' or the load path.
-;; It has the following format:
+;; A theme file is named `THEME-theme.el' (where THEME is the theme
+;; name) found in `custom-theme-load-path'. It has this format:
;;
;; (deftheme THEME
;; DOCSTRING)
"Like `deftheme', but THEME is evaluated as a normal argument.
FEATURE is the feature this theme provides. Normally, this is a symbol
created from THEME by `custom-make-theme-feature'."
- (if (memq theme '(user changed))
- (error "Custom theme cannot be named %S" theme))
+ (unless (custom-theme-name-valid-p theme)
+ (error "Custom theme cannot be named %S" theme))
(add-to-list 'custom-known-themes theme)
(put theme 'theme-feature feature)
(when doc (put theme 'theme-documentation doc)))
\f
;;; Loading themes.
-(defcustom custom-theme-directory
- user-emacs-directory
- "Directory in which Custom theme files should be written.
-`load-theme' searches this directory in addition to load-path.
-The command `customize-create-theme' writes the files it produces
-into this directory."
+(defcustom custom-theme-directory user-emacs-directory
+ "Default user directory for storing custom theme files.
+The command `customize-create-theme' writes theme files into this
+directory. By default, Emacs searches for custom themes in this
+directory first---see `custom-theme-load-path'."
:type 'string
:group 'customize
:version "22.1")
+(defcustom custom-theme-load-path (list 'custom-theme-directory t)
+ "List of directories to search for custom theme files.
+When loading custom themes (e.g. in `customize-themes' and
+`load-theme'), Emacs searches for theme files in the specified
+order. Each element in the list should be one of the following:
+- the symbol `custom-theme-directory', meaning the value of
+ `custom-theme-directory'.
+- the symbol t, meaning the built-in theme directory (a directory
+ named \"themes\" in `data-directory').
+- a directory name (a string).
+
+Each theme file is named NAME-theme.el, where THEME is the theme
+name."
+ :type '(repeat (choice (const :tag "custom-theme-directory"
+ custom-theme-directory)
+ (const :tag "Built-in theme directory" t)
+ directory))
+ :group 'customize
+ :version "24.1")
+
+(defvar custom--inhibit-theme-enable nil
+ "If non-nil, loading a theme does not enable it.
+This internal variable is set by `load-theme' when its NO-ENABLE
+argument is non-nil, and it affects `custom-theme-set-variables',
+`custom-theme-set-faces', and `provide-theme'." )
+
(defun provide-theme (theme)
"Indicate that this file provides THEME.
This calls `provide' to provide the feature name stored in THEME's
property `theme-feature' (which is usually a symbol created by
`custom-make-theme-feature')."
- (if (memq theme '(user changed))
- (error "Custom theme cannot be named %S" theme))
+ (unless (custom-theme-name-valid-p theme)
+ (error "Custom theme cannot be named %S" theme))
(custom-check-theme theme)
(provide (get theme 'theme-feature))
- ;; Loading a theme also enables it.
- (push theme custom-enabled-themes)
- ;; `user' must always be the highest-precedence enabled theme.
- ;; Make that remain true. (This has the effect of making user settings
- ;; override the ones just loaded, too.)
- (let ((custom-enabling-themes t))
- (enable-theme 'user)))
-
-(defun load-theme (theme)
+ (unless custom--inhibit-theme-enable
+ ;; By default, loading a theme also enables it.
+ (push theme custom-enabled-themes)
+ ;; `user' must always be the highest-precedence enabled theme.
+ ;; Make that remain true. (This has the effect of making user
+ ;; settings override the ones just loaded, too.)
+ (let ((custom-enabling-themes t))
+ (enable-theme 'user))))
+
+(defcustom custom-safe-themes '(default)
+ "List of themes that are considered safe to load.
+Each list element should be the `sha1' hash of a theme file, or
+the symbol `default', which stands for any theme in the built-in
+Emacs theme directory (a directory named \"themes\" in
+`data-directory')."
+ :type '(repeat
+ (choice string (const :tag "Built-in themes" default)))
+ :group 'customize
+ :risky t
+ :version "24.1")
+
+(defvar safe-functions) ; From unsafep.el
+
+(defun load-theme (theme &optional no-enable)
"Load a theme's settings from its file.
-This also enables the theme; use `disable-theme' to disable it."
- ;; Note we do no check for validity of the theme here.
- ;; This allows to pull in themes by a file-name convention
- (interactive "SCustom theme name: ")
+Normally, this also enables the theme; use `disable-theme' to
+disable it. If optional arg NO-ENABLE is non-nil, don't enable
+the theme.
+
+A theme file is named THEME-theme.el, where THEME is the theme name,
+in one of the directories specified by `custom-theme-load-path'."
+ (interactive
+ (list
+ (intern (completing-read "Load custom theme: "
+ (mapcar 'symbol-name
+ (custom-available-themes))))))
+ (unless (custom-theme-name-valid-p theme)
+ (error "Invalid theme name `%s'" theme))
;; If reloading, clear out the old theme settings.
(when (custom-theme-p theme)
(disable-theme theme)
(put theme 'theme-settings nil)
(put theme 'theme-feature nil)
(put theme 'theme-documentation nil))
- (let ((load-path (if (file-directory-p custom-theme-directory)
- (cons custom-theme-directory load-path)
- load-path)))
- (load (symbol-name (custom-make-theme-feature theme)))))
+ (let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
+ (custom-theme--load-path)
+ '("" "c")))
+ hash)
+ (unless fn
+ (error "Unable to find theme file for `%s'." theme))
+ (with-temp-buffer
+ (insert-file-contents fn)
+ (setq hash (sha1 (current-buffer)))
+ ;; Check file safety.
+ (when (or (and (memq 'default custom-safe-themes)
+ (equal (file-name-directory fn)
+ (expand-file-name "themes/" data-directory)))
+ (member hash custom-safe-themes)
+ ;; If the theme is not in `custom-safe-themes', check
+ ;; it with unsafep.
+ (progn
+ (require 'unsafep)
+ (let ((safe-functions
+ (append '(provide-theme deftheme
+ custom-theme-set-variables
+ custom-theme-set-faces)
+ safe-functions))
+ unsafep form)
+ (while (and (setq form (condition-case nil
+ (let ((read-circle nil))
+ (read (current-buffer)))
+ (end-of-file nil)))
+ (null (setq unsafep (unsafep form)))))
+ (or (null unsafep)
+ (custom-theme-load-confirm hash)))))
+ (let ((custom--inhibit-theme-enable no-enable))
+ (eval-buffer))))))
+
+(defun custom-theme-load-confirm (hash)
+ "Query the user about loading a Custom theme that may not be safe.
+The theme should be in the current buffer. If the user agrees,
+query also about adding HASH to `custom-safe-themes'."
+ (if noninteractive
+ nil
+ (let ((exit-chars '(?y ?n ?\s))
+ prompt char)
+ (save-window-excursion
+ (rename-buffer "*Custom Theme*" t)
+ (emacs-lisp-mode)
+ (display-buffer (current-buffer))
+ (setq prompt
+ (format "This theme is not guaranteed to be safe. Really load? %s"
+ (if (< (line-number-at-pos (point-max))
+ (window-body-height))
+ "(y or n) "
+ (push ?\C-v exit-chars)
+ "Type y or n, or C-v to scroll: ")))
+ (goto-char (point-min))
+ (while (null char)
+ (setq char (read-char-choice prompt exit-chars))
+ (when (eq char ?\C-v)
+ (condition-case nil
+ (scroll-up)
+ (error (goto-char (point-min))))
+ (setq char nil)))
+ (when (memq char '(?\s ?y))
+ (push hash custom-safe-themes)
+ ;; Offer to save to `custom-safe-themes'.
+ (and (or custom-file user-init-file)
+ (y-or-n-p "Treat this theme as safe for future loads? ")
+ (let ((coding-system-for-read nil))
+ (customize-save-variable 'custom-safe-themes
+ custom-safe-themes)))
+ t)))))
+
+(defun custom-theme-name-valid-p (name)
+ "Return t if NAME is a valid name for a Custom theme, nil otherwise.
+NAME should be a symbol."
+ (and (symbolp name)
+ name
+ (not (or (zerop (length (symbol-name name)))
+ (eq name 'user)
+ (eq name 'changed)))))
+
+(defun custom-available-themes ()
+ "Return a list of available Custom themes (symbols)."
+ (let* (sym themes)
+ (dolist (dir (custom-theme--load-path))
+ (when (file-directory-p dir)
+ (dolist (file (file-expand-wildcards
+ (expand-file-name "*-theme.el" dir) t))
+ (setq file (file-name-nondirectory file))
+ (and (string-match "\\`\\(.+\\)-theme.el\\'" file)
+ (setq sym (intern (match-string 1 file)))
+ (custom-theme-name-valid-p sym)
+ (push sym themes)))))
+ (delete-dups themes)))
+
+(defun custom-theme--load-path ()
+ (let (lpath)
+ (dolist (f custom-theme-load-path)
+ (cond ((eq f 'custom-theme-directory)
+ (setq f custom-theme-directory))
+ ((eq f t)
+ (setq f (expand-file-name "themes" data-directory))))
+ (if (file-directory-p f)
+ (push f lpath)))
+ (nreverse lpath)))
+
\f
;;; Enabling and disabling loaded themes.
If THEME does not specify any theme settings, this tries to load
the theme from its theme file, by calling `load-theme'."
- (interactive "SEnable Custom theme: ")
+ (interactive (list (intern
+ (completing-read
+ "Enable custom theme: "
+ obarray (lambda (sym) (get sym 'theme-settings))))))
(if (not (custom-theme-p theme))
(load-theme theme)
;; This could use a bit of optimization -- cyd
and always takes precedence over other Custom Themes."
:group 'customize
:type '(repeat symbol)
- :set-after '(custom-theme-directory) ; so we can find the themes
+ :set-after '(custom-theme-directory custom-theme-load-path)
+ :risky t
:set (lambda (symbol themes)
;; Avoid an infinite loop when custom-enabled-themes is
;; defined in a theme (e.g. `user'). Enabling the theme sets
See `custom-enabled-themes' for a list of enabled themes."
(interactive (list (intern
(completing-read
- "Disable Custom theme: "
+ "Disable custom theme: "
(mapcar 'symbol-name custom-enabled-themes)
nil t))))
(when (custom-theme-enabled-p theme)
(let ((settings (get theme 'theme-settings)))
(dolist (s settings)
- (let* ((prop (car s))
+ (let* ((prop (car s))
(symbol (cadr s))
- (spec-list (get symbol prop)))
- (put symbol prop (assq-delete-all theme spec-list))
- (if (eq prop 'theme-value)
- (custom-theme-recalc-variable symbol)
+ (val (assq-delete-all theme (get symbol prop))))
+ (put symbol prop val)
+ (cond
+ ((eq prop 'theme-value)
+ (custom-theme-recalc-variable symbol))
+ ((eq prop 'theme-face)
+ ;; If the face spec specified by this theme is in the
+ ;; saved-face property, reset that property.
+ (when (equal (nth 3 s) (get symbol 'saved-face))
+ (put symbol 'saved-face (and val (cadr (car val)))))
(custom-theme-recalc-face symbol)))))
- (setq custom-enabled-themes
- (delq theme custom-enabled-themes))))
+ (setq custom-enabled-themes
+ (delq theme custom-enabled-themes)))))
(defun custom-variable-theme-value (variable)
"Return (list VALUE) indicating the custom theme value of VARIABLE.
(defun custom-theme-recalc-face (face)
"Set FACE according to currently enabled custom themes."
- (if (facep face)
- (face-spec-set face
- (get (or (get face 'face-alias) face)
- 'face-override-spec))))
+ (if (get face 'face-alias)
+ (setq face (get face 'face-alias)))
+ ;; Reset the faces for each frame.
+ (dolist (frame (frame-list))
+ (face-spec-recalc face frame)))
+
\f
;;; XEmacs compability functions