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