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 | ||
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 |