X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/233ba4d924933cb56129bd7511e6137b7c0b8e3e..31eac1d10e23485d9ed38875300eb6ea8f8e61eb:/lisp/cus-theme.el

diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index cdc066aa91..928c54db92 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-2014 Free Software Foundation, Inc.
 ;;
 ;; Author: Alex Schroeder <alex@gnu.org>
-;; 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)
@@ -100,6 +104,9 @@ named *Custom Theme*."
   (make-local-variable 'custom-theme-insert-face-marker)
   (make-local-variable 'custom-theme-insert-variable-marker)
   (make-local-variable 'custom-theme--listed-faces)
+  (when (called-interactively-p 'interactive)
+    (unless (y-or-n-p "Include basic face customizations in this theme? ")
+      (setq custom-theme--listed-faces nil)))
 
   (if (eq theme 'user)
       (widget-insert "This buffer contains all the Custom settings you have made.
@@ -109,13 +116,13 @@ remove them from your saved Custom file.\n\n"))
   (widget-create 'push-button
 		 :tag " Visit Theme "
 		 :help-echo "Insert the settings of a pre-defined theme."
-		 :action (lambda (widget &optional event)
+		 :action (lambda (_widget &optional _event)
 			   (call-interactively 'custom-theme-visit-theme)))
   (widget-insert "  ")
   (widget-create 'push-button
 		 :tag " Merge Theme "
 		 :help-echo "Merge in the settings of a pre-defined theme."
-		 :action (lambda (widget &optional event)
+		 :action (lambda (_widget &optional _event)
 			   (call-interactively 'custom-theme-merge-theme)))
   (widget-insert "  ")
   (widget-create 'push-button
@@ -154,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)
@@ -179,7 +186,7 @@ remove them from your saved Custom file.\n\n"))
 		   :button-face 'custom-link
 		   :mouse-face 'highlight
 		   :pressed-face 'highlight
-		   :action (lambda (widget &optional event)
+		   :action (lambda (_widget &optional _event)
 			     (call-interactively 'custom-theme-add-face)))
 
     ;; If THEME is non-nil, insert all of that theme's variables.
@@ -188,7 +195,7 @@ remove them from your saved Custom file.\n\n"))
 	(while vars
 	  (if (eq (car vars) 'custom-enabled-themes)
 	      (progn (pop vars) (pop values))
-	    (custom-theme-add-var-1 (pop vars) (pop values)))))
+	    (custom-theme-add-var-1 (pop vars) (eval (pop values))))))
     (setq custom-theme-insert-variable-marker (point-marker))
     (widget-insert " ")
     (widget-create 'push-button
@@ -198,14 +205,16 @@ remove them from your saved Custom file.\n\n"))
 		   :button-face 'custom-link
 		   :mouse-face 'highlight
 		   :pressed-face 'highlight
-		   :action (lambda (widget &optional event)
+		   :action (lambda (_widget &optional _event)
 			     (call-interactively 'custom-theme-add-variable)))
     (widget-insert ?\n)
     (widget-setup)
     (goto-char (point-min))
     (message "")))
 
-(defun custom-theme-revert (ignore-auto noconfirm)
+(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))))
 
@@ -256,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)))
@@ -297,8 +306,9 @@ SPEC, if non-nil, should be a face spec to which to set the widget."
 
 ;;; Reading and writing
 
+;;;###autoload
 (defun custom-theme-visit-theme (theme)
-  "Load the custom theme THEME's settings into the current buffer."
+  "Set up a Custom buffer to edit custom theme THEME."
   (interactive
    (list
     (intern (completing-read "Find custom theme: "
@@ -322,17 +332,26 @@ 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)
 
-(defun custom-theme-write (&rest ignore)
+;; From cus-edit.el
+(defvar custom-reset-standard-faces-list)
+(defvar custom-reset-standard-variables-list)
+
+(defun custom-theme-write (&rest _ignore)
   "Write the current custom theme to its theme file."
   (interactive)
   (let* ((name (widget-value custom-theme-name))
@@ -424,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)
@@ -475,25 +497,24 @@ It includes all faces in list FACES."
 			       'help-theme-def fn)
       (princ "'"))
     (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
@@ -509,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)
@@ -523,13 +546,13 @@ 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)
   (custom--initialize-widget-variables)
   (set (make-local-variable 'revert-buffer-function)
-       (lambda (ignore-auto noconfirm)
+       (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)
@@ -562,7 +585,7 @@ Theme files are named *-theme.el in `"))
 		 :help-echo "Describe `custom-theme-load-path'."
 		 :keymap custom-mode-link-map
 		 :follow-link 'mouse-face
-		 :action (lambda (widget &rest ignore)
+		 :action (lambda (_widget &rest _ignore)
 			   (describe-variable 'custom-theme-load-path)))
   (widget-insert "'.\n\n")
 
@@ -585,7 +608,7 @@ Theme files are named *-theme.el in `"))
 		     :help-echo "Migrate."
 		     :keymap custom-mode-link-map
 		     :follow-link 'mouse-face
-		     :action (lambda (widget &rest ignore)
+		     :action (lambda (_widget &rest _ignore)
 			       (customize-create-theme 'user)))
       (widget-insert ".\n\n")))
 
@@ -597,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)
@@ -649,7 +702,7 @@ Theme files are named *-theme.el in `"))
     (and widget
 	 (describe-theme (widget-get widget :theme-name)))))
 
-(defun custom-theme-save (&rest ignore)
+(defun custom-theme-save (&rest _ignore)
   (interactive)
   (customize-save-variable 'custom-enabled-themes custom-enabled-themes)
   (message "Custom themes saved for future sessions."))
@@ -663,4 +716,6 @@ Theme files are named *-theme.el in `"))
   (widget-toggle-action widget event)
   (setq custom-theme-allow-multiple-selections (widget-value widget)))
 
+(provide 'cus-theme)
+
 ;;; cus-theme.el ends here