[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] /srv/bzr/emacs/trunk r101920: New interface for choosing C
|
From: |
Chong Yidong |
|
Subject: |
[Emacs-diffs] /srv/bzr/emacs/trunk r101920: New interface for choosing Custom themes. |
|
Date: |
Mon, 11 Oct 2010 23:10:21 -0400 |
|
User-agent: |
Bazaar (2.0.3) |
------------------------------------------------------------
revno: 101920
committer: Chong Yidong <address@hidden>
branch nick: trunk
timestamp: Mon 2010-10-11 23:10:21 -0400
message:
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.
modified:
lisp/ChangeLog
lisp/cus-edit.el
lisp/cus-face.el
lisp/cus-theme.el
lisp/custom.el
lisp/help-mode.el
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2010-10-12 02:31:16 +0000
+++ b/lisp/ChangeLog 2010-10-12 03:10:21 +0000
@@ -1,3 +1,38 @@
+2010-10-12 Chong Yidong <address@hidden>
+
+ * 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 <address@hidden>
* net/telnet.el (telnet-mode-map): Fix previous change (bug#7193).
=== modified file 'lisp/cus-edit.el'
--- a/lisp/cus-edit.el 2010-10-11 04:49:59 +0000
+++ b/lisp/cus-edit.el 2010-10-12 03:10:21 +0000
@@ -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 (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 @@
(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)
=== modified file 'lisp/cus-face.el'
--- a/lisp/cus-face.el 2010-08-29 16:17:13 +0000
+++ b/lisp/cus-face.el 2010-10-12 03:10:21 +0000
@@ -319,42 +319,32 @@
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
=== modified file 'lisp/cus-theme.el'
--- a/lisp/cus-theme.el 2010-10-09 21:54:20 +0000
+++ b/lisp/cus-theme.el 2010-10-12 03:10:21 +0000
@@ -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 @@
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 @@
(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 @@
: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 @@
(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 @@
(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 @@
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 @@
(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 @@
(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 @@
(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
=== modified file 'lisp/custom.el'
--- a/lisp/custom.el 2010-10-11 04:49:59 +0000
+++ b/lisp/custom.el 2010-10-12 03:10:21 +0000
@@ -959,48 +959,39 @@
(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 @@
: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 @@
(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 @@
(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)))
=== modified file 'lisp/help-mode.el'
--- a/lisp/help-mode.el 2010-08-29 16:17:13 +0000
+++ b/lisp/help-mode.el 2010-10-12 03:10:21 +0000
@@ -255,6 +255,15 @@
'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 ()
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] /srv/bzr/emacs/trunk r101920: New interface for choosing Custom themes.,
Chong Yidong <=