lisp/cus-theme.el

   1 ;;; cus-theme.el -- custom theme creation user interface
   2 ;;
   3 ;; Copyright (C) 2001, 2005 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Alex Schroeder <alex@gnu.org>
   6 ;; Maintainer: FSF
   7 ;; Keywords: help, faces
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Code:
  27
  28 (require 'widget)
  29 (require 'cus-edit)
  30
  31 (eval-when-compile
  32   (require 'wid-edit))
  33
  34 (define-derived-mode custom-new-theme-mode nil "New-Theme"
  35   "Major mode for the buffer created by `customize-create-theme'.
  36 Do not call this mode function yourself.  It is only meant for internal
  37 use by `customize-create-theme'."
  38   (set-keymap-parent custom-new-theme-mode-map widget-keymap))
  39 (put 'custom-new-theme-mode 'mode-class 'special)
  40
  41 (defvar custom-theme-name)
  42 (defvar custom-theme-variables)
  43 (defvar custom-theme-faces)
  44 (defvar custom-theme-description)
  45
  46 ;;;###autoload
  47 (defun customize-create-theme ()
  48   "Create a custom theme."
  49   (interactive)
  50   (if (get-buffer "*New Custom Theme*")
  51       (kill-buffer "*New Custom Theme*"))
  52   (switch-to-buffer "*New Custom Theme*")
  53   (let ((inhibit-read-only t))
  54     (erase-buffer))
  55   (custom-new-theme-mode)
  56   (make-local-variable 'custom-theme-name)
  57   (make-local-variable 'custom-theme-variables)
  58   (make-local-variable 'custom-theme-faces)
  59   (make-local-variable 'custom-theme-description)
  60   (widget-insert "This buffer helps you write a custom theme elisp file.
  61 This will help you share your customizations with other people.
  62
  63 Just insert the names of all variables and faces you want the theme
  64 to include.  Then clicking mouse-2 or pressing RET on the [Done] button
  65 will write a theme file that sets all these variables and faces to their
  66 current global values.  It will write that file into the directory given
  67 by the variable `custom-theme-directory', usually \"~/.emacs.d/\".
  68
  69 To undo all your edits to the buffer, use the [Reset] button.\n\n")
  70   (widget-insert "Theme name: ")
  71   (setq custom-theme-name
  72         (widget-create 'editable-field
  73                        :size 10
  74                        user-login-name))
  75   (widget-insert "\n\nDocumentation:\n")
  76   (setq custom-theme-description
  77         (widget-create 'text
  78                        :value (format-time-string "Created %Y-%m-%d.")))
  79   (widget-insert "\nVariables:\n\n")
  80   (setq custom-theme-variables
  81         (widget-create 'editable-list
  82                        :entry-format "%i %d %v"
  83                        'variable))
  84   (widget-insert "\nFaces:\n\n")
  85   (setq custom-theme-faces
  86         (widget-create 'editable-list
  87                        :entry-format "%i %d %v"
  88                        'face))
  89   (widget-insert "\n")
  90   (widget-create 'push-button
  91                  :notify (function custom-theme-write)
  92                  "Done")
  93   (widget-insert " ")
  94   (widget-create 'push-button
  95                  :notify (lambda (&rest ignore)
  96                            (customize-create-theme))
  97                  "Reset")
  98   (widget-insert " ")
  99   (widget-create 'push-button
 100                  :notify (lambda (&rest ignore)
 101                            (bury-buffer))
 102                  "Bury Buffer")
 103   (widget-insert "\n")
 104   (widget-setup))
 105
 106 (defun custom-theme-write (&rest ignore)
 107   (let ((name (widget-value custom-theme-name))
 108         (doc (widget-value custom-theme-description))
 109         (variables (widget-value custom-theme-variables))
 110         (faces (widget-value custom-theme-faces)))
 111     (switch-to-buffer (concat name "-theme.el"))
 112     (emacs-lisp-mode)
 113     (unless (file-exists-p custom-theme-directory)
 114       (make-directory (file-name-as-directory custom-theme-directory) t))
 115     (setq default-directory custom-theme-directory)
 116     (setq buffer-file-name (expand-file-name (concat name "-theme.el")))
 117     (let ((inhibit-read-only t))
 118       (erase-buffer))
 119     (insert "(deftheme " name)
 120     (when doc
 121       (newline)
 122       (insert "  \"" doc "\""))
 123     (insert  ")\n")
 124     (custom-theme-write-variables name variables)
 125     (custom-theme-write-faces name faces)
 126     (insert "\n(provide-theme '" name ")\n")
 127     (save-buffer)))
 128
 129 (defun custom-theme-write-variables (theme vars)
 130   "Write a `custom-theme-set-variables' command for THEME.
 131 It includes all variables in list VARS."
 132   ;; Most code is stolen from `custom-save-variables'.
 133   (when vars
 134     (let ((standard-output (current-buffer)))
 135       (princ "\n(custom-theme-set-variables\n")
 136       (princ " '")
 137       (princ theme)
 138       (princ "\n")
 139       (mapc (lambda (symbol)
 140               (when (boundp symbol)
 141                 (unless (bolp)
 142                   (princ "\n"))
 143                 (princ " '(")
 144                 (prin1 symbol)
 145                 (princ " ")
 146                 (prin1 (custom-quote (symbol-value symbol)))
 147                 (princ ")")))
 148               vars)
 149       (if (bolp)
 150           (princ " "))
 151       (princ ")")
 152       (unless (looking-at "\n")
 153         (princ "\n")))))
 154
 155 (defun custom-theme-write-faces (theme faces)
 156   "Write a `custom-theme-set-faces' command for THEME.
 157 It includes all faces in list FACES."
 158   (when faces
 159     (let ((standard-output (current-buffer)))
 160       (princ "\n(custom-theme-set-faces\n")
 161       (princ " '")
 162       (princ theme)
 163       (princ "\n")
 164       (mapc (lambda (symbol)
 165               (when (facep symbol)
 166                 (unless (bolp)
 167                   (princ "\n"))
 168                 (princ " '(")
 169                 (prin1 symbol)
 170                 (princ " ")
 171                 (prin1 (or (get symbol 'customized-face)
 172                            (get symbol 'face-defface-spec)))
 173                 (princ ")")))
 174               faces)
 175       (if (bolp)
 176           (princ " "))
 177       (princ ")")
 178       (unless (looking-at "\n")
 179         (princ "\n")))))
 180
 181 ;;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
 182 ;;; cus-theme.el ends here