1;;; cus-theme.el -- custom theme creation user interface 2;; 3;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 4;; 2006, 2007 Free Software Foundation, Inc. 5;; 6;; Author: Alex Schroeder <alex@gnu.org> 7;; Maintainer: FSF 8;; Keywords: help, faces 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software; you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation; either version 2, or (at your option) 15;; any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs; see the file COPYING. If not, write to the 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Code: 28 29(require 'widget) 30(require 'cus-edit) 31 32(eval-when-compile 33 (require 'wid-edit)) 34 35(defvar custom-new-theme-mode-map 36 (let ((map (make-keymap))) 37 (set-keymap-parent map widget-keymap) 38 (suppress-keymap map) 39 (define-key map "n" 'widget-forward) 40 (define-key map "p" 'widget-backward) 41 map) 42 "Keymap for `custom-new-theme-mode'.") 43 44(define-derived-mode custom-new-theme-mode nil "New-Theme" 45 "Major mode for the buffer created by `customize-create-theme'. 46Do not call this mode function yourself. It is only meant for internal 47use by `customize-create-theme'." 48 (use-local-map custom-new-theme-mode-map) 49 (define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke) 50 (set (make-local-variable 'widget-documentation-face) 'custom-documentation) 51 (set (make-local-variable 'widget-button-face) custom-button) 52 (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed) 53 (set (make-local-variable 'widget-mouse-face) custom-button-mouse) 54 (when custom-raised-buttons 55 (set (make-local-variable 'widget-push-button-prefix) "") 56 (set (make-local-variable 'widget-push-button-suffix) "") 57 (set (make-local-variable 'widget-link-prefix) "") 58 (set (make-local-variable 'widget-link-suffix) ""))) 59(put 'custom-new-theme-mode 'mode-class 'special) 60 61(defvar custom-theme-name nil) 62(defvar custom-theme-variables nil) 63(defvar custom-theme-faces nil) 64(defvar custom-theme-description) 65(defvar custom-theme-insert-variable-marker) 66(defvar custom-theme-insert-face-marker) 67 68;;;###autoload 69(defun customize-create-theme () 70 "Create a custom theme." 71 (interactive) 72 (switch-to-buffer (generate-new-buffer "*New Custom Theme*")) 73 (let ((inhibit-read-only t)) 74 (erase-buffer)) 75 (custom-new-theme-mode) 76 (make-local-variable 'custom-theme-name) 77 (make-local-variable 'custom-theme-variables) 78 (make-local-variable 'custom-theme-faces) 79 (make-local-variable 'custom-theme-description) 80 (make-local-variable 'custom-theme-insert-variable-marker) 81 (make-local-variable 'custom-theme-insert-face-marker) 82 (widget-insert "This buffer helps you write a custom theme elisp file. 83This will help you share your customizations with other people. 84 85Insert the names of all variables and faces you want the theme to include. 86Invoke \"Save Theme\" to save the theme. The theme file will be saved to 87the directory " custom-theme-directory "\n\n") 88 (widget-create 'push-button 89 :tag "Visit Theme" 90 :help-echo "Insert the settings of a pre-defined theme." 91 :action (lambda (widget &optional event) 92 (call-interactively 'custom-theme-visit-theme))) 93 (widget-insert " ") 94 (widget-create 'push-button 95 :tag "Merge Theme" 96 :help-echo "Merge in the settings of a pre-defined theme." 97 :action (lambda (widget &optional event) 98 (call-interactively 'custom-theme-merge-theme))) 99 (widget-insert " ") 100 (widget-create 'push-button 101 :notify (lambda (&rest ignore) 102 (when (y-or-n-p "Discard current changes? ") 103 (kill-buffer (current-buffer)) 104 (customize-create-theme))) 105 "Reset Buffer") 106 (widget-insert " ") 107 (widget-create 'push-button 108 :notify (function custom-theme-write) 109 "Save Theme") 110 (widget-insert "\n") 111 112 (widget-insert "\n\nTheme name: ") 113 (setq custom-theme-name 114 (widget-create 'editable-field 115 :size 10 116 user-login-name)) 117 (widget-insert "\n\nDocumentation:\n") 118 (setq custom-theme-description 119 (widget-create 'text 120 :value (format-time-string "Created %Y-%m-%d."))) 121 (widget-insert "\n") 122 (widget-create 'push-button 123 :tag "Insert Variable" 124 :help-echo "Add another variable to this theme." 125 :action (lambda (widget &optional event) 126 (call-interactively 'custom-theme-add-variable))) 127 (widget-insert "\n") 128 (setq custom-theme-insert-variable-marker (point-marker)) 129 (widget-insert "\n") 130 (widget-create 'push-button 131 :tag "Insert Face" 132 :help-echo "Add another face to this theme." 133 :action (lambda (widget &optional event) 134 (call-interactively 'custom-theme-add-face))) 135 (widget-insert "\n") 136 (setq custom-theme-insert-face-marker (point-marker)) 137 (widget-insert "\n") 138 (widget-create 'push-button 139 :notify (lambda (&rest ignore) 140 (when (y-or-n-p "Discard current changes? ") 141 (kill-buffer (current-buffer)) 142 (customize-create-theme))) 143 "Reset Buffer") 144 (widget-insert " ") 145 (widget-create 'push-button 146 :notify (function custom-theme-write) 147 "Save Theme") 148 (widget-insert "\n") 149 (widget-setup) 150 (goto-char (point-min)) 151 (message "")) 152 153;;; Theme variables 154 155(defun custom-theme-add-variable (symbol) 156 (interactive "vVariable name: ") 157 (cond ((assq symbol custom-theme-variables) 158 (message "%s is already in the theme" (symbol-name symbol))) 159 ((not (boundp symbol)) 160 (message "%s is not defined as a variable" (symbol-name symbol))) 161 ((eq symbol 'custom-enabled-themes) 162 (message "Custom theme cannot contain `custom-enabled-themes'")) 163 (t 164 (save-excursion 165 (goto-char custom-theme-insert-variable-marker) 166 (widget-insert "\n") 167 (let ((widget (widget-create 'custom-variable 168 :tag (custom-unlispify-tag-name symbol) 169 :custom-level 0 170 :action 'custom-theme-variable-action 171 :custom-state 'unknown 172 :value symbol))) 173 (push (cons symbol widget) custom-theme-variables) 174 (custom-magic-reset widget)) 175 (widget-setup))))) 176 177(defvar custom-theme-variable-menu 178 `(("Reset to Current" custom-redraw 179 (lambda (widget) 180 (and (boundp (widget-value widget)) 181 (memq (widget-get widget :custom-state) 182 '(themed modified changed))))) 183 ("Reset to Theme Value" custom-variable-reset-theme 184 (lambda (widget) 185 (let ((theme (intern (widget-value custom-theme-name))) 186 (symbol (widget-value widget)) 187 found) 188 (and (custom-theme-p theme) 189 (dolist (setting (get theme 'theme-settings) found) 190 (if (and (eq (cadr setting) symbol) 191 (eq (car setting) 'theme-value)) 192 (setq found t))))))) 193 ("---" ignore ignore) 194 ("Delete" custom-theme-delete-variable nil)) 195 "Alist of actions for the `custom-variable' widget in Custom Theme Mode. 196See the documentation for `custom-variable'.") 197 198(defun custom-theme-variable-action (widget &optional event) 199 "Show the Custom Theme Mode menu for a `custom-variable' widget. 200Optional EVENT is the location for the menu." 201 (let ((custom-variable-menu custom-theme-variable-menu)) 202 (custom-variable-action widget event))) 203 204(defun custom-variable-reset-theme (widget) 205 "Reset WIDGET to its value for the currently edited theme." 206 (let ((theme (intern (widget-value custom-theme-name))) 207 (symbol (widget-value widget)) 208 found) 209 (dolist (setting (get theme 'theme-settings)) 210 (if (and (eq (cadr setting) symbol) 211 (eq (car setting) 'theme-value)) 212 (setq found setting))) 213 (widget-value-set (car (widget-get widget :children)) 214 (nth 3 found))) 215 (widget-put widget :custom-state 'themed) 216 (custom-redraw-magic widget) 217 (widget-setup)) 218 219(defun custom-theme-delete-variable (widget) 220 (setq custom-theme-variables 221 (assq-delete-all (widget-value widget) custom-theme-variables)) 222 (widget-delete widget)) 223 224;;; Theme faces 225 226(defun custom-theme-add-face (symbol) 227 (interactive (list (read-face-name "Face name" nil nil))) 228 (cond ((assq symbol custom-theme-faces) 229 (message "%s is already in the theme" (symbol-name symbol))) 230 ((not (facep symbol)) 231 (message "%s is not defined as a face" (symbol-name symbol))) 232 (t 233 (save-excursion 234 (goto-char custom-theme-insert-face-marker) 235 (widget-insert "\n") 236 (let ((widget (widget-create 'custom-face 237 :tag (custom-unlispify-tag-name symbol) 238 :custom-level 0 239 :action 'custom-theme-face-action 240 :custom-state 'unknown 241 :value symbol))) 242 (push (cons symbol widget) custom-theme-faces) 243 (custom-magic-reset widget) 244 (widget-setup)))))) 245 246(defvar custom-theme-face-menu 247 `(("Reset to Theme Value" custom-face-reset-theme 248 (lambda (widget) 249 (let ((theme (intern (widget-value custom-theme-name))) 250 (symbol (widget-value widget)) 251 found) 252 (and (custom-theme-p theme) 253 (dolist (setting (get theme 'theme-settings) found) 254 (if (and (eq (cadr setting) symbol) 255 (eq (car setting) 'theme-face)) 256 (setq found t))))))) 257 ("---" ignore ignore) 258 ("Delete" custom-theme-delete-face nil)) 259 "Alist of actions for the `custom-variable' widget in Custom Theme Mode. 260See the documentation for `custom-variable'.") 261 262(defun custom-theme-face-action (widget &optional event) 263 "Show the Custom Theme Mode menu for a `custom-face' widget. 264Optional EVENT is the location for the menu." 265 (let ((custom-face-menu custom-theme-face-menu)) 266 (custom-face-action widget event))) 267 268(defun custom-face-reset-theme (widget) 269 "Reset WIDGET to its value for the currently edited theme." 270 (let ((theme (intern (widget-value custom-theme-name))) 271 (symbol (widget-value widget)) 272 found) 273 (dolist (setting (get theme 'theme-settings)) 274 (if (and (eq (cadr setting) symbol) 275 (eq (car setting) 'theme-face)) 276 (setq found setting))) 277 (widget-value-set (car (widget-get widget :children)) 278 (nth 3 found))) 279 (widget-put widget :custom-state 'themed) 280 (custom-redraw-magic widget) 281 (widget-setup)) 282 283(defun custom-theme-delete-face (widget) 284 (setq custom-theme-faces 285 (assq-delete-all (widget-value widget) custom-theme-faces)) 286 (widget-delete widget)) 287 288;;; Reading and writing 289 290(defun custom-theme-visit-theme () 291 (interactive) 292 (when (or (null custom-theme-variables) 293 (if (y-or-n-p "Discard current changes? ") 294 (progn (customize-create-theme) t))) 295 (let ((theme (call-interactively 'custom-theme-merge-theme))) 296 (unless (eq theme 'user) 297 (widget-value-set custom-theme-name (symbol-name theme))) 298 (widget-value-set custom-theme-description 299 (or (get theme 'theme-documentation) 300 (format-time-string "Created %Y-%m-%d."))) 301 (widget-setup)))) 302 303(defun custom-theme-merge-theme (theme) 304 (interactive "SCustom theme name: ") 305 (unless (eq theme 'user) 306 (load-theme theme)) 307 (let ((settings (get theme 'theme-settings))) 308 (dolist (setting settings) 309 (if (eq (car setting) 'theme-value) 310 (custom-theme-add-variable (cadr setting)) 311 (custom-theme-add-face (cadr setting))))) 312 (disable-theme theme) 313 theme) 314 315(defun custom-theme-write (&rest ignore) 316 (let* ((name (widget-value custom-theme-name)) 317 (filename (expand-file-name (concat name "-theme.el") 318 custom-theme-directory)) 319 (doc (widget-value custom-theme-description)) 320 (vars custom-theme-variables) 321 (faces custom-theme-faces)) 322 (cond ((or (string-equal name "") 323 (string-equal name "user") 324 (string-equal name "changed")) 325 (error "Custom themes cannot be named `%s'" name)) 326 ((string-match " " name) 327 (error "Custom theme names should not contain spaces")) 328 ((if (file-exists-p filename) 329 (not (y-or-n-p 330 (format "File %s exists. Overwrite? " filename)))) 331 (error "Aborted"))) 332 (with-temp-buffer 333 (emacs-lisp-mode) 334 (unless (file-exists-p custom-theme-directory) 335 (make-directory (file-name-as-directory custom-theme-directory) t)) 336 (setq buffer-file-name filename) 337 (erase-buffer) 338 (insert "(deftheme " name) 339 (if doc (insert "\n \"" doc "\"")) 340 (insert ")\n") 341 (custom-theme-write-variables name vars) 342 (custom-theme-write-faces name faces) 343 (insert "\n(provide-theme '" name ")\n") 344 (save-buffer)) 345 (dolist (var vars) 346 (widget-put (cdr var) :custom-state 'saved) 347 (custom-redraw-magic (cdr var))) 348 (dolist (face faces) 349 (widget-put (cdr face) :custom-state 'saved) 350 (custom-redraw-magic (cdr face))))) 351 352(defun custom-theme-write-variables (theme vars) 353 "Write a `custom-theme-set-variables' command for THEME. 354It includes all variables in list VARS." 355 (when vars 356 (let ((standard-output (current-buffer))) 357 (princ "\n(custom-theme-set-variables\n") 358 (princ " '") 359 (princ theme) 360 (princ "\n") 361 (mapc (lambda (spec) 362 (let* ((symbol (car spec)) 363 (child (car-safe (widget-get (cdr spec) :children))) 364 (value (if child 365 (widget-value child) 366 ;; For hidden widgets, use the standard value 367 (get symbol 'standard-value)))) 368 (when (boundp symbol) 369 (unless (bolp) 370 (princ "\n")) 371 (princ " '(") 372 (prin1 symbol) 373 (princ " ") 374 (prin1 (custom-quote value)) 375 (princ ")")))) 376 vars) 377 (if (bolp) 378 (princ " ")) 379 (princ ")") 380 (unless (looking-at "\n") 381 (princ "\n"))))) 382 383(defun custom-theme-write-faces (theme faces) 384 "Write a `custom-theme-set-faces' command for THEME. 385It includes all faces in list FACES." 386 (when faces 387 (let ((standard-output (current-buffer))) 388 (princ "\n(custom-theme-set-faces\n") 389 (princ " '") 390 (princ theme) 391 (princ "\n") 392 (mapc (lambda (spec) 393 (let* ((symbol (car spec)) 394 (child (car-safe (widget-get (cdr spec) :children))) 395 (value (if child (widget-value child)))) 396 (when (and (facep symbol) child) 397 (unless (bolp) 398 (princ "\n")) 399 (princ " '(") 400 (prin1 symbol) 401 (princ " ") 402 (prin1 value) 403 (princ ")")))) 404 faces) 405 (if (bolp) 406 (princ " ")) 407 (princ ")") 408 (unless (looking-at "\n") 409 (princ "\n"))))) 410 411;;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344 412;;; cus-theme.el ends here 413