X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/db0406bb64f7e5dceeb257c7e350f1e80ed9c1c1..2cbd80a5f8a75aa7516a9f0cc467b72c05e94b4a:/lisp/cus-theme.el diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index 86fb43be72..3160e23d9e 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -1,9 +1,9 @@ ;;; cus-theme.el -- custom theme creation user interface ;; -;; Copyright (C) 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 2001-2016 Free Software Foundation, Inc. ;; ;; Author: Alex Schroeder -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: help, faces ;; Package: emacs @@ -32,9 +32,11 @@ (defvar custom-new-theme-mode-map (let ((map (make-keymap))) - (set-keymap-parent map widget-keymap) + (set-keymap-parent map (make-composed-keymap widget-keymap + special-mode-map)) (suppress-keymap map) (define-key map "\C-x\C-s" 'custom-theme-write) + (define-key map "q" 'Custom-buffer-done) (define-key map "n" 'widget-forward) (define-key map "p" 'widget-backward) map) @@ -81,7 +83,9 @@ Do not call this mode function yourself. It is meant for internal use." (defun customize-create-theme (&optional theme buffer) "Create or edit a custom theme. THEME, if non-nil, should be an existing theme to edit. If THEME -is `user', provide an option to remove these as custom settings. +is `user', the resulting *Custom Theme* buffer also contains a +checkbox for removing the theme settings specified in the buffer +from the Custom save file. BUFFER, if non-nil, should be a buffer to use; the default is named *Custom Theme*." (interactive) @@ -157,7 +161,7 @@ remove them from your saved Custom file.\n\n")) ;; Load the theme settings. (when theme (unless (eq theme 'user) - (load-theme theme t)) + (load-theme theme nil t)) (dolist (setting (get theme 'theme-settings)) (if (eq (car setting) 'theme-value) (progn (push (nth 1 setting) vars) @@ -209,6 +213,8 @@ remove them from your saved Custom file.\n\n")) (message ""))) (defun custom-theme-revert (_ignore-auto noconfirm) + "Revert the current *Custom Theme* buffer. +This is the `revert-buffer-function' for `custom-new-theme-mode'." (when (or noconfirm (y-or-n-p "Discard current changes? ")) (customize-create-theme custom-theme--save-name (current-buffer)))) @@ -259,7 +265,7 @@ interactively, this defaults to the current value of VAR." (defun custom-theme-add-face (face &optional spec) "Add a widget for FACE (a symbol) to the *New Custom Theme* buffer. SPEC, if non-nil, should be a face spec to which to set the widget." - (interactive (list (read-face-name "Face name" nil nil) nil)) + (interactive (list (read-face-name "Face name" (face-at-point t)))) (unless (or (facep face) spec) (error "`%s' has no face definition" face)) (let ((entry (assq face custom-theme-faces))) @@ -326,14 +332,19 @@ SPEC, if non-nil, should be a face spec to which to set the widget." (unless (eq theme 'user) (unless (custom-theme-name-valid-p theme) (error "Invalid theme name `%s'" theme)) - (load-theme theme t)) + (load-theme theme nil t)) (let ((settings (reverse (get theme 'theme-settings)))) (dolist (setting settings) - (funcall (if (eq (car setting) 'theme-value) - 'custom-theme-add-variable - 'custom-theme-add-face) - (nth 1 setting) - (nth 3 setting)))) + (let ((option (eq (car setting) 'theme-value)) + (name (nth 1 setting)) + (value (nth 3 setting))) + (unless (and option + (memq name '(custom-enabled-themes + custom-safe-themes))) + (funcall (if option + 'custom-theme-add-variable + 'custom-theme-add-face) + name value))))) theme) ;; From cus-edit.el @@ -432,14 +443,17 @@ It includes all faces in list FACES." (princ theme) (princ "\n") (dolist (spec faces) + ;; Insert the face iff the checkbox widget is checked. (when (widget-get (nth 1 spec) :value) (let* ((symbol (nth 0 spec)) (widget (nth 2 spec)) (value - (if (car-safe (widget-get widget :children)) - (custom-face-widget-to-spec widget) - ;; Child is null if the widget is closed (hidden). - (widget-get widget :shown-value)))) + (cond + ((car-safe (widget-get widget :children)) + (custom-face-widget-to-spec widget)) + ;; Child is null if the widget is closed (hidden). + ((widget-get widget :shown-value)) + (t (custom-face-get-current-spec symbol))))) (when (and (facep symbol) value) (princ (if (bolp) " '(" "\n '(")) (prin1 symbol) @@ -478,33 +492,32 @@ It includes all faces in list FACES." '("" "c"))) doc) (when fn - (princ " in `") + (princ (substitute-command-keys " in `")) (help-insert-xref-button (file-name-nondirectory fn) 'help-theme-def fn) - (princ "'")) + (princ (substitute-command-keys "'"))) (princ ".\n") - (if (not (memq theme custom-known-themes)) + (if (custom-theme-p theme) (progn - (princ "It is not loaded.") - ;; Attempt to grab the theme documentation - (when fn - (with-temp-buffer - (insert-file-contents fn) - (let ((sexp (let ((read-circle nil)) - (condition-case nil - (read (current-buffer)) - (end-of-file nil))))) - (and sexp (listp sexp) - (eq (car sexp) 'deftheme) - (setq doc (nth 2 sexp))))))) - (if (custom-theme-enabled-p theme) - (princ "It is loaded and enabled.") - (princ "It is loaded but disabled.")) - (setq doc (get theme 'theme-documentation))) - + (if (custom-theme-enabled-p theme) + (princ "It is loaded and enabled.") + (princ "It is loaded but disabled.")) + (setq doc (get theme 'theme-documentation))) + (princ "It is not loaded.") + ;; Attempt to grab the theme documentation + (when fn + (with-temp-buffer + (insert-file-contents fn) + (let ((sexp (let ((read-circle nil)) + (condition-case nil + (read (current-buffer)) + (end-of-file nil))))) + (and sexp (listp sexp) + (eq (car sexp) 'deftheme) + (setq doc (nth 2 sexp))))))) (princ "\n\nDocumentation:\n") (princ (if (stringp doc) - doc + (substitute-command-keys doc) "No documentation available."))) (princ "\n\nYou can ") (help-insert-xref-button "customize" 'help-theme-edit theme) @@ -517,12 +530,14 @@ It includes all faces in list FACES." (defcustom custom-theme-allow-multiple-selections nil "Whether to allow multi-selections in the *Custom Themes* buffer." + :version "24.1" :type 'boolean :group 'custom-buffer) (defvar custom-theme-choose-mode-map (let ((map (make-keymap))) - (set-keymap-parent map widget-keymap) + (set-keymap-parent map (make-composed-keymap widget-keymap + special-mode-map)) (suppress-keymap map) (define-key map "\C-x\C-s" 'custom-theme-save) (define-key map "n" 'widget-forward) @@ -531,7 +546,7 @@ It includes all faces in list FACES." map) "Keymap for `custom-theme-choose-mode'.") -(define-derived-mode custom-theme-choose-mode nil "Themes" +(define-derived-mode custom-theme-choose-mode special-mode "Themes" "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) @@ -572,7 +587,7 @@ Theme files are named *-theme.el in `")) :follow-link 'mouse-face :action (lambda (_widget &rest _ignore) (describe-variable 'custom-theme-load-path))) - (widget-insert "'.\n\n") + (widget-insert (substitute-command-keys "'.\n\n")) ;; If the user has made customizations, display a warning and ;; provide buttons to disable or convert them. @@ -605,26 +620,56 @@ Theme files are named *-theme.el in `")) (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" + (widget-insert (propertize " Select more than one theme at a time" 'face '(variable-pitch (:height 0.9)))) (widget-insert "\n\nAvailable Custom Themes:\n") - (let (widget) + (let ((help-echo "mouse-2: Enable this theme for this session") + widget) (dolist (theme (custom-available-themes)) (setq widget (widget-create 'checkbox :value (custom-theme-enabled-p theme) :theme-name theme + :help-echo help-echo :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))) + :action 'widget-parent-action + :help-echo help-echo) + (widget-insert " -- " + (propertize (custom-theme-summary theme) + 'face 'shadow) + ?\n))) (goto-char (point-min)) (widget-setup)) +(defun custom-theme-summary (theme) + "Return the summary line of THEME." + (let (doc) + (if (custom-theme-p theme) + (setq doc (get theme 'theme-documentation)) + (let ((fn (locate-file (concat (symbol-name theme) "-theme.el") + (custom-theme--load-path) + '("" "c")))) + (when fn + (with-temp-buffer + (insert-file-contents fn) + (let ((sexp (let ((read-circle nil)) + (condition-case nil + (read (current-buffer)) + (end-of-file nil))))) + (and sexp (listp sexp) + (eq (car sexp) 'deftheme) + (setq doc (nth 2 sexp)))))))) + (cond ((null doc) + "(no documentation available)") + ((string-match ".*" doc) + (match-string 0 doc)) + (t doc)))) + (defun custom-theme-checkbox-toggle (widget &optional event) (let ((this-theme (widget-get widget :theme-name))) (if (widget-value widget)