Commit | Line | Data |
---|---|---|
3656dac0 RS |
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 | ||
87e391a9 | 34 | ;;;###autoload |
f560e69c | 35 | (defun customize-create-theme () |
3656dac0 RS |
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 | |
71296446 | 57 | (widget-create 'text |
3656dac0 RS |
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) | |
392cb21b | 76 | (customize-create-theme)) |
3656dac0 RS |
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 | ;;; cus-theme.el ends here |