New interface for choosing Custom themes.
* lisp/cus-edit.el (custom--initialize-widget-variables): New function. (Custom-mode): Use it. * lisp/cus-face.el (custom-theme-set-faces): Remove dead code. Obey custom--inhibit-theme-enable. * lisp/cus-theme.el (describe-theme, customize-themes) (custom-theme-save): New commands. (custom-new-theme-mode-map): Bind C-x C-s. (custom-new-theme-mode): Use custom--initialize-widget-variables. (customize-create-theme): New optional arg THEME. (custom-theme-revert): Use it. (custom-theme-visit-theme): Remove dead code. (custom-theme-merge-theme): Use custom-available-themes. (custom-theme-write): Make interactive. (custom-theme-write): Use custom-theme-name-valid-p. (describe-theme-1, custom-theme-choose-revert) (custom-theme-checkbox-toggle, custom-theme-selections-toggle): New funs. (custom-theme-allow-multiple-selections): New option. (custom-theme-choose-mode): New major mode. * lisp/custom.el (custom-theme-set-variables): Remove dead code. Obey custom--inhibit-theme-enable. (custom--inhibit-theme-enable): New var. (provide-theme): Obey it. (load-theme): Replace load with manual read/eval, in order to check for correctness. Use custom-theme-name-valid-p. (custom-theme-name-valid-p): New function. (custom-available-themes): Use it. * lisp/help-mode.el (help-theme-def, help-theme-edit): New buttons.
This commit is contained in:
Chong Yidong
parent
57b6ae5351
commit
6b09b5d118
6 changed files with 415 additions and 152 deletions
|
|
@ -1,3 +1,38 @@
|
|||
2010-10-12 Chong Yidong <cyd@stupidchicken.com>
|
||||
|
||||
* cus-theme.el (describe-theme, customize-themes)
|
||||
(custom-theme-save): New commands.
|
||||
(custom-new-theme-mode-map): Bind C-x C-s.
|
||||
(custom-new-theme-mode): Use custom--initialize-widget-variables.
|
||||
(customize-create-theme): New optional arg THEME.
|
||||
(custom-theme-revert): Use it.
|
||||
(custom-theme-visit-theme): Remove dead code.
|
||||
(custom-theme-merge-theme): Use custom-available-themes.
|
||||
(custom-theme-write): Make interactive.
|
||||
(custom-theme-write): Use custom-theme-name-valid-p.
|
||||
(describe-theme-1, custom-theme-choose-revert)
|
||||
(custom-theme-checkbox-toggle, custom-theme-selections-toggle):
|
||||
New funs.
|
||||
(custom-theme-allow-multiple-selections): New option.
|
||||
(custom-theme-choose-mode): New major mode.
|
||||
|
||||
* custom.el (custom-theme-set-variables): Remove dead code. Obey
|
||||
custom--inhibit-theme-enable.
|
||||
(custom--inhibit-theme-enable): New var.
|
||||
(provide-theme): Obey it.
|
||||
(load-theme): Replace load with manual read/eval, in order to
|
||||
check for correctness. Use custom-theme-name-valid-p.
|
||||
(custom-theme-name-valid-p): New function.
|
||||
(custom-available-themes): Use it.
|
||||
|
||||
* cus-edit.el (custom--initialize-widget-variables): New function.
|
||||
(Custom-mode): Use it.
|
||||
|
||||
* cus-face.el (custom-theme-set-faces): Remove dead code. Obey
|
||||
custom--inhibit-theme-enable.
|
||||
|
||||
* help-mode.el (help-theme-def, help-theme-edit): New buttons.
|
||||
|
||||
2010-10-12 Juanma Barranquero <lekktu@gmail.com>
|
||||
|
||||
* net/telnet.el (telnet-mode-map): Fix previous change (bug#7193).
|
||||
|
|
|
|||
|
|
@ -439,9 +439,6 @@
|
|||
;;; Custom mode keymaps
|
||||
|
||||
(defvar custom-mode-map
|
||||
;; This keymap should be dense, but a dense keymap would prevent inheriting
|
||||
;; "\r" bindings from the parent map.
|
||||
;; Actually, this misfeature of dense keymaps was fixed on 2001-11-26.
|
||||
(let ((map (make-keymap)))
|
||||
(set-keymap-parent map widget-keymap)
|
||||
(define-key map [remap self-insert-command] 'Custom-no-edit)
|
||||
|
|
@ -4706,6 +4703,25 @@ If several parents are listed, go to the first of them."
|
|||
(if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified)
|
||||
(message "To install your edits, invoke [State] and choose the Set operation")))
|
||||
|
||||
(defun custom--initialize-widget-variables ()
|
||||
(set (make-local-variable 'widget-documentation-face) 'custom-documentation)
|
||||
(set (make-local-variable 'widget-button-face) custom-button)
|
||||
(set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
|
||||
(set (make-local-variable 'widget-mouse-face) custom-button-mouse)
|
||||
;; We need this because of the "More" button on docstrings.
|
||||
;; Otherwise clicking on "More" can push point offscreen, which
|
||||
;; causes the window to recenter on point, which pushes the
|
||||
;; newly-revealed docstring offscreen; which is annoying. -- cyd.
|
||||
(set (make-local-variable 'widget-button-click-moves-point) t)
|
||||
;; When possible, use relief for buttons, not bracketing. This test
|
||||
;; may not be optimal.
|
||||
(when custom-raised-buttons
|
||||
(set (make-local-variable 'widget-push-button-prefix) "")
|
||||
(set (make-local-variable 'widget-push-button-suffix) "")
|
||||
(set (make-local-variable 'widget-link-prefix) "")
|
||||
(set (make-local-variable 'widget-link-suffix) ""))
|
||||
(setq show-trailing-whitespace nil))
|
||||
|
||||
(define-derived-mode Custom-mode nil "Custom"
|
||||
"Major mode for editing customization buffers.
|
||||
|
||||
|
|
@ -4743,28 +4759,7 @@ if that value is non-nil."
|
|||
(setq custom-tool-bar-map map))))
|
||||
(make-local-variable 'custom-options)
|
||||
(make-local-variable 'custom-local-buffer)
|
||||
(make-local-variable 'widget-documentation-face)
|
||||
(setq widget-documentation-face 'custom-documentation)
|
||||
(make-local-variable 'widget-button-face)
|
||||
(setq widget-button-face custom-button)
|
||||
(setq show-trailing-whitespace nil)
|
||||
|
||||
;; We need this because of the "More" button on docstrings.
|
||||
;; Otherwise clicking on "More" can push point offscreen, which
|
||||
;; causes the window to recenter on point, which pushes the
|
||||
;; newly-revealed docstring offscreen; which is annoying. -- cyd.
|
||||
(set (make-local-variable 'widget-button-click-moves-point) t)
|
||||
|
||||
(set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
|
||||
(set (make-local-variable 'widget-mouse-face) custom-button-mouse)
|
||||
|
||||
;; When possible, use relief for buttons, not bracketing. This test
|
||||
;; may not be optimal.
|
||||
(when custom-raised-buttons
|
||||
(set (make-local-variable 'widget-push-button-prefix) "")
|
||||
(set (make-local-variable 'widget-push-button-suffix) "")
|
||||
(set (make-local-variable 'widget-link-prefix) "")
|
||||
(set (make-local-variable 'widget-link-suffix) ""))
|
||||
(custom--initialize-widget-variables)
|
||||
(add-hook 'widget-edit-functions 'custom-state-buffer-message nil t))
|
||||
|
||||
(put 'Custom-mode 'mode-class 'special)
|
||||
|
|
|
|||
|
|
@ -319,42 +319,32 @@ 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))
|
||||
oldspec)
|
||||
;; If FACE is actually an alias, customize the face it
|
||||
;; is aliased to.
|
||||
(if (get face 'face-alias)
|
||||
(setq face (get face 'face-alias)))
|
||||
|
||||
(setq oldspec (get face 'theme-face))
|
||||
(when (not (and oldspec (eq 'user (caar oldspec))))
|
||||
(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)
|
||||
(put face 'face-override-spec nil)
|
||||
(face-spec-set face spec t))
|
||||
(setq args (cdr args)))
|
||||
;; Old format, a plist of FACE SPEC pairs.
|
||||
(let ((face (nth 0 args))
|
||||
(spec (nth 1 args)))
|
||||
(if (get face 'face-alias)
|
||||
(setq face (get face 'face-alias)))
|
||||
(put face 'saved-face spec)
|
||||
(custom-push-theme 'theme-face face theme 'set spec))
|
||||
(setq args (cdr (cdr args))))))))
|
||||
(dolist (entry args)
|
||||
(unless (listp entry)
|
||||
(error "Incompatible Custom theme spec"))
|
||||
(let ((face (car entry))
|
||||
(spec (nth 1 entry)))
|
||||
;; If FACE is actually an alias, customize the face it
|
||||
;; is aliased to.
|
||||
(if (get face 'face-alias)
|
||||
(setq face (get face 'face-alias)))
|
||||
(custom-push-theme 'theme-face face theme 'set spec)
|
||||
(unless custom--inhibit-theme-enable
|
||||
;; Now set the face spec.
|
||||
(let ((now (nth 2 entry))
|
||||
(comment (nth 3 entry))
|
||||
(oldspec (get face 'theme-face)))
|
||||
(when (not (and oldspec (eq 'user (caar oldspec))))
|
||||
(put face 'saved-face spec)
|
||||
(put face 'saved-face-comment comment))
|
||||
(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)
|
||||
(put face 'face-override-spec nil)
|
||||
(face-spec-set face spec t))))))))
|
||||
|
||||
;; XEmacs compability function. In XEmacs, when you reset a Custom
|
||||
;; Theme, you have to specify the theme to reset it to. We just apply
|
||||
|
|
|
|||
|
|
@ -35,27 +35,18 @@
|
|||
(let ((map (make-keymap)))
|
||||
(set-keymap-parent map widget-keymap)
|
||||
(suppress-keymap map)
|
||||
(define-key map "\C-x\C-s" 'custom-theme-write)
|
||||
(define-key map "n" 'widget-forward)
|
||||
(define-key map "p" 'widget-backward)
|
||||
map)
|
||||
"Keymap for `custom-new-theme-mode'.")
|
||||
|
||||
(define-derived-mode custom-new-theme-mode nil "New-Theme"
|
||||
"Major mode for the buffer created by `customize-create-theme'.
|
||||
Do not call this mode function yourself. It is only meant for internal
|
||||
use by `customize-create-theme'."
|
||||
(define-derived-mode custom-new-theme-mode nil "Cus-Theme"
|
||||
"Major mode for editing Custom themes.
|
||||
Do not call this mode function yourself. It is meant for internal use."
|
||||
(use-local-map custom-new-theme-mode-map)
|
||||
(define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke)
|
||||
(set (make-local-variable 'widget-documentation-face) 'custom-documentation)
|
||||
(set (make-local-variable 'widget-button-face) custom-button)
|
||||
(set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
|
||||
(set (make-local-variable 'widget-mouse-face) custom-button-mouse)
|
||||
(set (make-local-variable 'revert-buffer-function) 'custom-theme-revert)
|
||||
(when custom-raised-buttons
|
||||
(set (make-local-variable 'widget-push-button-prefix) "")
|
||||
(set (make-local-variable 'widget-push-button-suffix) "")
|
||||
(set (make-local-variable 'widget-link-prefix) "")
|
||||
(set (make-local-variable 'widget-link-suffix) "")))
|
||||
(custom--initialize-widget-variables)
|
||||
(set (make-local-variable 'revert-buffer-function) 'custom-theme-revert))
|
||||
(put 'custom-new-theme-mode 'mode-class 'special)
|
||||
|
||||
(defvar custom-theme-name nil)
|
||||
|
|
@ -82,17 +73,21 @@ use by `customize-create-theme'."
|
|||
query-replace)
|
||||
"Faces listed by default in the *Custom Theme* buffer.")
|
||||
|
||||
(defvar custom-theme--save-name)
|
||||
|
||||
;;;###autoload
|
||||
(defun customize-create-theme (&optional buffer)
|
||||
"Create a custom theme.
|
||||
(defun customize-create-theme (&optional theme buffer)
|
||||
"Create or edit a custom theme.
|
||||
THEME, if non-nil, should be an existing theme to edit.
|
||||
BUFFER, if non-nil, should be a buffer to use."
|
||||
(interactive)
|
||||
(switch-to-buffer (or buffer (generate-new-buffer "*Custom Theme*")))
|
||||
(switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*")))
|
||||
;; Save current faces
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer))
|
||||
(custom-new-theme-mode)
|
||||
(make-local-variable 'custom-theme-name)
|
||||
(set (make-local-variable 'custom-theme--save-name) theme)
|
||||
(set (make-local-variable 'custom-theme-faces) nil)
|
||||
(set (make-local-variable 'custom-theme-variables) nil)
|
||||
(set (make-local-variable 'custom-theme-description) "")
|
||||
|
|
@ -116,7 +111,8 @@ BUFFER, if non-nil, should be a buffer to use."
|
|||
|
||||
(widget-insert "\n\nTheme name : ")
|
||||
(setq custom-theme-name
|
||||
(widget-create 'editable-field))
|
||||
(widget-create 'editable-field
|
||||
:value (if theme (symbol-name theme) "")))
|
||||
(widget-insert "Description: ")
|
||||
(setq custom-theme-description
|
||||
(widget-create 'text
|
||||
|
|
@ -164,14 +160,15 @@ BUFFER, if non-nil, should be a buffer to use."
|
|||
:action (lambda (widget &optional event)
|
||||
(call-interactively 'custom-theme-add-variable)))
|
||||
(widget-insert ?\n)
|
||||
(if theme
|
||||
(custom-theme-merge-theme theme))
|
||||
(widget-setup)
|
||||
(goto-char (point-min))
|
||||
(message ""))
|
||||
|
||||
(defun custom-theme-revert (ignore-auto noconfirm)
|
||||
(when (or noconfirm (y-or-n-p "Discard current changes? "))
|
||||
(erase-buffer)
|
||||
(customize-create-theme (current-buffer))))
|
||||
(customize-create-theme custom-theme--save-name (current-buffer))))
|
||||
|
||||
;;; Theme variables
|
||||
|
||||
|
|
@ -318,10 +315,8 @@ Optional EVENT is the location for the menu."
|
|||
|
||||
(defun custom-theme-visit-theme ()
|
||||
(interactive)
|
||||
(when (or (and (null custom-theme-variables)
|
||||
(null custom-theme-faces))
|
||||
(and (y-or-n-p "Discard current changes? ")
|
||||
(progn (revert-buffer) t)))
|
||||
(when (and (y-or-n-p "Discard current changes? ")
|
||||
(progn (revert-buffer) t))
|
||||
(let ((theme (call-interactively 'custom-theme-merge-theme)))
|
||||
(unless (eq theme 'user)
|
||||
(widget-value-set custom-theme-name (symbol-name theme)))
|
||||
|
|
@ -331,9 +326,14 @@ Optional EVENT is the location for the menu."
|
|||
(widget-setup))))
|
||||
|
||||
(defun custom-theme-merge-theme (theme)
|
||||
(interactive "SCustom theme name: ")
|
||||
(unless (eq theme 'user)
|
||||
(load-theme theme))
|
||||
(interactive
|
||||
(list
|
||||
(intern (completing-read "Merge custom theme: "
|
||||
(mapcar 'symbol-name
|
||||
(custom-available-themes))))))
|
||||
(unless (custom-theme-name-valid-p theme)
|
||||
(error "Invalid theme name `%s'" theme))
|
||||
(load-theme theme)
|
||||
(let ((settings (get theme 'theme-settings)))
|
||||
(dolist (setting settings)
|
||||
(if (eq (car setting) 'theme-value)
|
||||
|
|
@ -343,6 +343,7 @@ Optional EVENT is the location for the menu."
|
|||
theme)
|
||||
|
||||
(defun custom-theme-write (&rest ignore)
|
||||
(interactive)
|
||||
(let* ((name (widget-value custom-theme-name))
|
||||
(doc (widget-value custom-theme-description))
|
||||
(vars custom-theme-variables)
|
||||
|
|
@ -351,12 +352,8 @@ Optional EVENT is the location for the menu."
|
|||
(when (string-equal name "")
|
||||
(setq name (read-from-minibuffer "Theme name: " (user-login-name)))
|
||||
(widget-value-set custom-theme-name name))
|
||||
(cond ((or (string-equal name "")
|
||||
(string-equal name "user")
|
||||
(string-equal name "changed"))
|
||||
(error "Custom themes cannot be named `%s'" name))
|
||||
((string-match " " name)
|
||||
(error "Custom theme names should not contain spaces")))
|
||||
(unless (custom-theme-name-valid-p (intern name))
|
||||
(error "Custom themes cannot be named `%s'" name))
|
||||
|
||||
(setq filename (expand-file-name (concat name "-theme.el")
|
||||
custom-theme-directory))
|
||||
|
|
@ -384,7 +381,8 @@ Optional EVENT is the location for the menu."
|
|||
(dolist (face custom-theme-faces)
|
||||
(when (widget-get (cdr face) :children)
|
||||
(widget-put (cdr face) :custom-state 'saved)
|
||||
(custom-redraw-magic (cdr face))))))
|
||||
(custom-redraw-magic (cdr face))))
|
||||
(message "Theme written to %s" filename)))
|
||||
|
||||
(defun custom-theme-write-variables (theme vars)
|
||||
"Write a `custom-theme-set-variables' command for THEME.
|
||||
|
|
@ -456,5 +454,196 @@ It includes all faces in list FACES."
|
|||
(unless (looking-at "\n")
|
||||
(princ "\n")))))
|
||||
|
||||
|
||||
;;; Describing Custom themes.
|
||||
|
||||
;;;###autoload
|
||||
(defun describe-theme (theme)
|
||||
"Display a description of the Custom theme THEME (a symbol)."
|
||||
(interactive
|
||||
(list
|
||||
(intern (completing-read "Describe custom theme: "
|
||||
(mapcar 'symbol-name
|
||||
(custom-available-themes))))))
|
||||
(unless (custom-theme-name-valid-p theme)
|
||||
(error "Invalid theme name `%s'" theme))
|
||||
(help-setup-xref (list 'describe-theme theme)
|
||||
(called-interactively-p 'interactive))
|
||||
(with-help-window (help-buffer)
|
||||
(with-current-buffer standard-output
|
||||
(describe-theme-1 theme))))
|
||||
|
||||
(defun describe-theme-1 (theme)
|
||||
(prin1 theme)
|
||||
(princ " is a custom theme")
|
||||
(let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
|
||||
(cons custom-theme-directory load-path)
|
||||
'("" "c"))))
|
||||
(when fn
|
||||
(princ " in `")
|
||||
(help-insert-xref-button (file-name-nondirectory fn)
|
||||
'help-theme-def fn)
|
||||
(princ "'"))
|
||||
(princ ".\n"))
|
||||
(if (not (memq theme custom-known-themes))
|
||||
(princ "It is not loaded.")
|
||||
(if (custom-theme-enabled-p theme)
|
||||
(princ "It is loaded and enabled.\n")
|
||||
(princ "It is loaded but disabled.\n"))
|
||||
(princ "\nDocumentation:\n")
|
||||
(princ (or (get theme 'theme-documentation)
|
||||
"No documentation available.")))
|
||||
(princ "\n\nYou can ")
|
||||
(help-insert-xref-button "customize" 'help-theme-edit theme)
|
||||
(princ " this theme."))
|
||||
|
||||
|
||||
;;; Theme chooser
|
||||
|
||||
(defvar custom--listed-themes)
|
||||
|
||||
(defcustom custom-theme-allow-multiple-selections nil
|
||||
"Whether to allow multi-selections in the *Custom Themes* buffer."
|
||||
:type 'boolean
|
||||
:group 'custom-buffer)
|
||||
|
||||
(defvar custom-theme-choose-mode-map
|
||||
(let ((map (make-keymap)))
|
||||
(set-keymap-parent map widget-keymap)
|
||||
(suppress-keymap map)
|
||||
(define-key map "\C-x\C-s" 'custom-theme-save)
|
||||
(define-key map "n" 'widget-forward)
|
||||
(define-key map "p" 'widget-backward)
|
||||
(define-key map "?" 'custom-describe-theme)
|
||||
map)
|
||||
"Keymap for `custom-theme-choose-mode'.")
|
||||
|
||||
(define-derived-mode custom-theme-choose-mode nil "Cus-Theme"
|
||||
"Major mode for selecting Custom themes.
|
||||
Do not call this mode function yourself. It is meant for internal use."
|
||||
(use-local-map custom-theme-choose-mode-map)
|
||||
(custom--initialize-widget-variables)
|
||||
(set (make-local-variable 'revert-buffer-function)
|
||||
(lambda (ignore-auto noconfirm)
|
||||
(when (or noconfirm (y-or-n-p "Discard current choices? "))
|
||||
(customize-themes (current-buffer))))))
|
||||
(put 'custom-theme-choose-mode 'mode-class 'special)
|
||||
|
||||
;;;###autoload
|
||||
(defun customize-themes (&optional buffer)
|
||||
"Display a selectable list of Custom themes.
|
||||
When called from Lisp, BUFFER should be the buffer to use; if
|
||||
omitted, a buffer named *Custom Themes* is used."
|
||||
(interactive)
|
||||
(pop-to-buffer (get-buffer-create (or buffer "*Custom Themes*")))
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer))
|
||||
(custom-theme-choose-mode)
|
||||
(set (make-local-variable 'custom--listed-themes) nil)
|
||||
(make-local-variable 'custom-theme-allow-multiple-selections)
|
||||
(and (null custom-theme-allow-multiple-selections)
|
||||
(> (length custom-enabled-themes) 1)
|
||||
(setq custom-theme-allow-multiple-selections t))
|
||||
|
||||
(widget-insert
|
||||
(substitute-command-keys
|
||||
"Type RET or click to enable/disable listed custom themes.
|
||||
Type \\[custom-describe-theme] to describe the theme at point.
|
||||
Theme files are named *-theme.el in `"))
|
||||
(when (stringp custom-theme-directory)
|
||||
(widget-create 'link :value custom-theme-directory
|
||||
:button-face 'custom-link
|
||||
:mouse-face 'highlight
|
||||
:pressed-face 'highlight
|
||||
:help-echo "Describe `custom-theme-directory'."
|
||||
:keymap custom-mode-link-map
|
||||
:follow-link 'mouse-face
|
||||
:action (lambda (widget &rest ignore)
|
||||
(describe-variable 'custom-theme-directory)))
|
||||
(widget-insert "' or `"))
|
||||
(widget-create 'link :value "load-path"
|
||||
:button-face 'custom-link
|
||||
:mouse-face 'highlight
|
||||
:pressed-face 'highlight
|
||||
:help-echo "Describe `load-path'."
|
||||
:keymap custom-mode-link-map
|
||||
:follow-link 'mouse-face
|
||||
:action (lambda (widget &rest ignore)
|
||||
(describe-variable 'load-path)))
|
||||
(widget-insert "'.\n\n")
|
||||
(widget-create 'push-button
|
||||
:tag " Save Theme Settings "
|
||||
:help-echo "Save the selected themes for future sessions."
|
||||
:action 'custom-theme-save)
|
||||
(widget-insert ?\n)
|
||||
(widget-create 'checkbox
|
||||
:value custom-theme-allow-multiple-selections
|
||||
:action 'custom-theme-selections-toggle)
|
||||
(widget-insert (propertize " Allow more than one theme at a time"
|
||||
'face '(variable-pitch (:height 0.9))))
|
||||
|
||||
(widget-insert "\n\nAvailable Custom Themes:\n")
|
||||
(let (widget)
|
||||
(dolist (theme (custom-available-themes))
|
||||
(setq widget (widget-create 'checkbox
|
||||
:value (custom-theme-enabled-p theme)
|
||||
:theme-name theme
|
||||
:action 'custom-theme-checkbox-toggle))
|
||||
(push (cons theme widget) custom--listed-themes)
|
||||
(widget-create-child-and-convert widget 'push-button
|
||||
:button-face-get 'ignore
|
||||
:mouse-face-get 'ignore
|
||||
:value (format " %s" theme)
|
||||
:action 'widget-parent-action)
|
||||
(widget-insert ?\n)))
|
||||
(goto-char (point-min))
|
||||
(widget-setup))
|
||||
|
||||
(defun custom-theme-checkbox-toggle (widget &optional event)
|
||||
(let ((this-theme (widget-get widget :theme-name)))
|
||||
(if (widget-value widget)
|
||||
;; Disable the theme.
|
||||
(disable-theme this-theme)
|
||||
;; Enable the theme.
|
||||
(unless custom-theme-allow-multiple-selections
|
||||
;; If only one theme is allowed, disable all other themes and
|
||||
;; uncheck their boxes.
|
||||
(dolist (theme custom-enabled-themes)
|
||||
(and (not (eq theme this-theme))
|
||||
(assq theme custom--listed-themes)
|
||||
(disable-theme theme)))
|
||||
(dolist (theme custom--listed-themes)
|
||||
(unless (eq (car theme) this-theme)
|
||||
(widget-value-set (cdr theme) nil)
|
||||
(widget-apply (cdr theme) :notify (cdr theme) event))))
|
||||
(load-theme this-theme)))
|
||||
;; Mark `custom-enabled-themes' as "set for current session".
|
||||
(put 'custom-enabled-themes 'customized-value
|
||||
(list (custom-quote custom-enabled-themes)))
|
||||
;; Check/uncheck the widget.
|
||||
(widget-toggle-action widget event))
|
||||
|
||||
(defun custom-describe-theme ()
|
||||
"Describe the Custom theme on the current line."
|
||||
(interactive)
|
||||
(let ((widget (widget-at (line-beginning-position))))
|
||||
(and widget
|
||||
(describe-theme (widget-get widget :theme-name)))))
|
||||
|
||||
(defun custom-theme-save (&rest ignore)
|
||||
(interactive)
|
||||
(customize-save-variable 'custom-enabled-themes custom-enabled-themes)
|
||||
(message "Custom themes saved for future sessions."))
|
||||
|
||||
(defun custom-theme-selections-toggle (widget &optional event)
|
||||
(when (widget-value widget)
|
||||
;; Deactivate multiple-selections.
|
||||
(if (> (length (delq nil (mapcar (lambda (x) (widget-value (cdr x)))
|
||||
custom--listed-themes)))
|
||||
1)
|
||||
(error "More than one theme is currently selected")))
|
||||
(widget-toggle-action widget event)
|
||||
(setq custom-theme-allow-multiple-selections (widget-value widget)))
|
||||
|
||||
;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
|
||||
;;; cus-theme.el ends here
|
||||
|
|
|
|||
157
lisp/custom.el
157
lisp/custom.el
|
|
@ -959,48 +959,39 @@ in SYMBOL's list property `theme-value' \(using `custom-push-theme')."
|
|||
(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)))))))
|
||||
|
||||
|
||||
;;; Defining themes.
|
||||
|
|
@ -1072,6 +1063,12 @@ into this directory."
|
|||
:group 'customize
|
||||
:version "22.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
|
||||
|
|
@ -1081,35 +1078,83 @@ property `theme-feature' (which is usually a symbol created by
|
|||
(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)))
|
||||
(unless custom--inhibit-theme-enable
|
||||
;; 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)
|
||||
(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."
|
||||
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."
|
||||
;; Note we do no check for validity of the theme here.
|
||||
;; This allows to pull in themes by a file-name convention
|
||||
(interactive
|
||||
(list
|
||||
(intern (completing-read "Load custom theme: "
|
||||
(mapcar 'symbol-name (custom-available-themes))))))
|
||||
(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")
|
||||
(cons custom-theme-directory load-path)
|
||||
'("" "c"))))
|
||||
(unless fn
|
||||
(error "Unable to find theme file for `%s'." theme))
|
||||
;; Instead of simply loading the theme file, read it manually.
|
||||
(with-temp-buffer
|
||||
(insert-file-contents fn)
|
||||
(let ((custom--inhibit-theme-enable no-enable)
|
||||
sexp scar)
|
||||
(while (setq sexp (let ((read-circle nil))
|
||||
(condition-case nil
|
||||
(read (current-buffer))
|
||||
(end-of-file nil))))
|
||||
;; Perform some checks on each sexp before evaluating it.
|
||||
(cond
|
||||
((not (listp sexp)))
|
||||
((eq (setq scar (car sexp)) 'deftheme)
|
||||
(unless (eq (cadr sexp) theme)
|
||||
(error "Incorrect theme name in `deftheme'"))
|
||||
(and (symbolp (nth 1 sexp))
|
||||
(stringp (nth 2 sexp))
|
||||
(eval (list scar (nth 1 sexp) (nth 2 sexp)))))
|
||||
((or (eq scar 'custom-theme-set-variables)
|
||||
(eq scar 'custom-theme-set-faces))
|
||||
(unless (equal (nth 1 sexp) `(quote ,theme))
|
||||
(error "Incorrect theme name in theme settings"))
|
||||
(dolist (entry (cddr sexp))
|
||||
(unless (eq (car-safe entry) 'quote)
|
||||
(error "Unsafe expression in theme settings")))
|
||||
(eval sexp))
|
||||
((and (eq scar 'provide-theme)
|
||||
(equal (cadr sexp) `(quote ,theme))
|
||||
(= (length sexp) 2))
|
||||
(eval sexp))))))))
|
||||
|
||||
(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 'cus)
|
||||
(eq name 'user)
|
||||
(eq name 'changed)))))
|
||||
|
||||
(defun custom-available-themes ()
|
||||
"Return a list of available Custom themes (symbols)."
|
||||
(let* ((load-path (if (file-directory-p custom-theme-directory)
|
||||
(cons custom-theme-directory load-path)
|
||||
load-path))
|
||||
|
|
@ -1120,7 +1165,7 @@ This also enables the theme; use `disable-theme' to disable it."
|
|||
(setq file (file-name-nondirectory file))
|
||||
(and (string-match "\\`\\(.+\\)-theme.el\\'" file)
|
||||
(setq sym (intern (match-string 1 file)))
|
||||
(not (memq sym '(cus user changed color)))
|
||||
(custom-theme-name-valid-p sym)
|
||||
(push sym themes))))
|
||||
(delete-dups themes)))
|
||||
|
||||
|
|
|
|||
|
|
@ -255,6 +255,15 @@ The format is (FUNCTION ARGS...).")
|
|||
'help-function (lambda (file) (dired file))
|
||||
'help-echo (purecopy "mouse-2, RET: visit package directory"))
|
||||
|
||||
(define-button-type 'help-theme-def
|
||||
:supertype 'help-xref
|
||||
'help-function 'find-file
|
||||
'help-echo (purecopy "mouse-2, RET: visit theme file"))
|
||||
|
||||
(define-button-type 'help-theme-edit
|
||||
:supertype 'help-xref
|
||||
'help-function 'customize-create-theme
|
||||
'help-echo (purecopy "mouse-2, RET: edit this theme file"))
|
||||
|
||||
;;;###autoload
|
||||
(defun help-mode ()
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue