diff options
| -rw-r--r-- | lisp/ChangeLog | 35 | ||||
| -rw-r--r-- | lisp/cus-edit.el | 45 | ||||
| -rw-r--r-- | lisp/cus-face.el | 62 | ||||
| -rw-r--r-- | lisp/cus-theme.el | 259 | ||||
| -rw-r--r-- | lisp/custom.el | 159 | ||||
| -rw-r--r-- | lisp/help-mode.el | 9 |
6 files changed, 416 insertions, 153 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 99f7c20e72e..e32d07f7db7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -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). diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 1b69d0c59b2..f7090bc322f 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -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) diff --git a/lisp/cus-face.el b/lisp/cus-face.el index f6a07507f2c..1a24429e1e8 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -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 diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index d8192e860e4..3c1295ea923 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -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 diff --git a/lisp/custom.el b/lisp/custom.el index 681b55f9178..ffb3a271fa4 100644 --- a/lisp/custom.el +++ b/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))) - -(defun load-theme (theme) + (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 &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))) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 9d10d5170ba..9f54ff08c0b 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -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 () |