lisp/cus-theme.el

   1 ;;; cus-theme.el -- custom theme creation user interface
   2 ;;
   3 ;; Copyright (C) 2001 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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'widget)
  29 (require 'cus-edit)
  30
  31 (eval-when-compile
  32   (require 'wid-edit))
  33
  34 ;;;###autoload
  35 (defun customize-create-theme ()
  36   "Create a custom theme."
  37   (interactive)
  38   (if (get-buffer "*New Custom Theme*")
  39       (kill-buffer "*New Custom Theme*"))
  40   (switch-to-buffer "*New Custom Theme*")
  41   (kill-all-local-variables)
  42   (make-local-variable 'custom-theme-name)
  43   (make-local-variable 'custom-theme-variables)
  44   (make-local-variable 'custom-theme-faces)
  45   (make-local-variable 'custom-theme-description)
  46   (let ((inhibit-read-only t))
  47     (erase-buffer))
  48   (widget-insert "This buffer helps you write a custom theme elisp file.
  49 This will help you share your customizations with other people.\n\n")
  50   (widget-insert "Theme name: ")
  51   (setq custom-theme-name
  52         (widget-create 'editable-field
  53                        :size 10
  54                        user-login-name))
  55   (widget-insert "\n\nDocumentation:\n")
  56   (setq custom-theme-description
  57         (widget-create 'text
  58                        :value (format-time-string "Created %Y-%m-%d.")))
  59   (widget-insert "\nVariables:\n\n")
  60   (setq custom-theme-variables
  61         (widget-create 'editable-list
  62                        :entry-format "%i %d %v"
  63                        'variable))
  64   (widget-insert "\nFaces:\n\n")
  65   (setq custom-theme-faces
  66         (widget-create 'editable-list
  67                        :entry-format "%i %d %v"
  68                        'face))
  69   (widget-insert "\n")
  70   (widget-create 'push-button
  71                  :notify (function custom-theme-write)
  72                  "Done")
  73   (widget-insert " ")
  74   (widget-create 'push-button
  75                  :notify (lambda (&rest ignore)
  76                            (customize-create-theme))
  77                  "Reset")
  78   (widget-insert " ")
  79   (widget-create 'push-button
  80                  :notify (lambda (&rest ignore)
  81                            (bury-buffer))
  82                  "Bury Buffer")
  83   (widget-insert "\n")
  84   (use-local-map widget-keymap)
  85   (widget-setup))
  86
  87 (defun custom-theme-write (&rest ignore)
  88   (let ((name (widget-value custom-theme-name))
  89         (doc (widget-value custom-theme-description))
  90         (variables (widget-value custom-theme-variables))
  91         (faces (widget-value custom-theme-faces)))
  92     (switch-to-buffer (concat name "-theme.el"))
  93     (setq buffer-file-name (expand-file-name (concat name "-theme.el")))
  94     (let ((inhibit-read-only t))
  95       (erase-buffer))
  96     (insert "(deftheme " name)
  97     (when doc
  98       (newline)
  99       (insert "  \"" doc "\""))
 100     (insert  ")\n")
 101     (custom-theme-write-variables name variables)
 102     (custom-theme-write-faces name faces)
 103     (insert "\n(provide-theme '" name ")\n")))
 104
 105 (defun custom-theme-write-variables (theme vars)
 106   "Write a `custom-theme-set-variables' command for THEME.
 107 It includes all variables in list VARS."
 108   ;; Most code is stolen from `custom-save-variables'.
 109   (when vars
 110     (let ((standard-output (current-buffer)))
 111       (princ "\n(custom-theme-set-variables\n")
 112       (princ " '")
 113       (princ theme)
 114       (princ "\n")
 115       (mapc (lambda (symbol)
 116               (when (boundp symbol)
 117                 (unless (bolp)
 118                   (princ "\n"))
 119                 (princ " '(")
 120                 (prin1 symbol)
 121                 (princ " ")
 122                 (prin1 (symbol-value symbol))
 123                 (princ ")")))
 124               vars)
 125       (if (bolp)
 126           (princ " "))
 127       (princ ")")
 128       (unless (looking-at "\n")
 129         (princ "\n")))))
 130
 131 (defun custom-theme-write-faces (theme faces)
 132   "Write a `custom-theme-set-faces' command for THEME.
 133 It includes all faces in list FACES."
 134   (when faces
 135     (let ((standard-output (current-buffer)))
 136       (princ "\n(custom-theme-set-faces\n")
 137       (princ " '")
 138       (princ theme)
 139       (princ "\n")
 140       (mapc (lambda (symbol)
 141               (when (facep symbol)
 142                 (unless (bolp)
 143                   (princ "\n"))
 144                 (princ " '(")
 145                 (prin1 symbol)
 146                 (princ " ")
 147                 (prin1 (or (get symbol 'customized-face)
 148                            (get symbol 'face-defface-spec)))
 149                 (princ ")")))
 150               faces)
 151       (if (bolp)
 152           (princ " "))
 153       (princ ")")
 154       (unless (looking-at "\n")
 155         (princ "\n")))))
 156
 157 ;;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
 158 ;;; cus-theme.el ends here