Mercurial > hg > xemacs-beta
comparison lisp/custom.el @ 428:3ecd8885ac67 r21-2-22
Import from CVS: tag r21-2-22
author | cvs |
---|---|
date | Mon, 13 Aug 2007 11:28:15 +0200 |
parents | |
children | 8de8e3f6228a |
comparison
equal
deleted
inserted
replaced
427:0a0253eac470 | 428:3ecd8885ac67 |
---|---|
1 ;;; custom.el -- Tools for declaring and initializing options. | |
2 | |
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | |
6 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org> | |
7 ;; Keywords: help, faces, dumped | |
8 ;; Version: 1.9960-x | |
9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | |
10 | |
11 ;; This file is part of XEmacs. | |
12 | |
13 ;; XEmacs is free software; you can redistribute it and/or modify | |
14 ;; it under the terms of the GNU General Public License as published by | |
15 ;; the Free Software Foundation; either version 2, or (at your option) | |
16 ;; any later version. | |
17 | |
18 ;; XEmacs is distributed in the hope that it will be useful, | |
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 ;; GNU General Public License for more details. | |
22 | |
23 ;; You should have received a copy of the GNU General Public License | |
24 ;; along with XEmacs; see the file COPYING. If not, write to the | |
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
26 ;; Boston, MA 02111-1307, USA. | |
27 | |
28 ;;; Commentary: | |
29 | |
30 ;; This file is dumped with XEmacs. | |
31 | |
32 ;; This file only contain the code needed to declare and initialize | |
33 ;; user options. The code to customize options is autoloaded from | |
34 ;; `cus-edit.el'. | |
35 ;; | |
36 ;; The code implementing face declarations is in `cus-face.el' | |
37 | |
38 ;;; Code: | |
39 | |
40 (eval-when-compile | |
41 (load "cl-macs")) | |
42 | |
43 (if (not (fboundp 'defun*)) | |
44 (autoload 'defun* "cl-macs")) | |
45 | |
46 (require 'widget) | |
47 | |
48 (defvar custom-define-hook nil | |
49 ;; Customize information for this option is in `cus-edit.el'. | |
50 "Hook called after defining each customize option.") | |
51 | |
52 ;;; The `defcustom' Macro. | |
53 | |
54 (defun custom-initialize-default (symbol value) | |
55 "Initialize SYMBOL with VALUE. | |
56 This will do nothing if symbol already has a default binding. | |
57 Otherwise, if symbol has a `saved-value' property, it will evaluate | |
58 the car of that and used as the default binding for symbol. | |
59 Otherwise, VALUE will be evaluated and used as the default binding for | |
60 symbol." | |
61 (unless (default-boundp symbol) | |
62 ;; Use the saved value if it exists, otherwise the standard setting. | |
63 (set-default symbol (if (get symbol 'saved-value) | |
64 (eval (car (get symbol 'saved-value))) | |
65 (eval value))))) | |
66 | |
67 (defun custom-initialize-set (symbol value) | |
68 "Initialize SYMBOL with VALUE. | |
69 Like `custom-initialize-default', but use the function specified by | |
70 `:set' to initialize SYMBOL." | |
71 (unless (default-boundp symbol) | |
72 (funcall (or (get symbol 'custom-set) 'set-default) | |
73 symbol | |
74 (if (get symbol 'saved-value) | |
75 (eval (car (get symbol 'saved-value))) | |
76 (eval value))))) | |
77 | |
78 (defun custom-initialize-reset (symbol value) | |
79 "Initialize SYMBOL with VALUE. | |
80 Like `custom-initialize-set', but use the function specified by | |
81 `:get' to reinitialize SYMBOL if it is already bound." | |
82 (funcall (or (get symbol 'custom-set) 'set-default) | |
83 symbol | |
84 (cond ((default-boundp symbol) | |
85 (funcall (or (get symbol 'custom-get) 'default-value) | |
86 symbol)) | |
87 ((get symbol 'saved-value) | |
88 (eval (car (get symbol 'saved-value)))) | |
89 (t | |
90 (eval value))))) | |
91 | |
92 (defun custom-initialize-changed (symbol value) | |
93 "Initialize SYMBOL with VALUE. | |
94 Like `custom-initialize-reset', but only use the `:set' function if the | |
95 not using the standard setting. Otherwise, use the `set-default'." | |
96 (cond ((default-boundp symbol) | |
97 (funcall (or (get symbol 'custom-set) 'set-default) | |
98 symbol | |
99 (funcall (or (get symbol 'custom-get) 'default-value) | |
100 symbol))) | |
101 ((get symbol 'saved-value) | |
102 (funcall (or (get symbol 'custom-set) 'set-default) | |
103 symbol | |
104 (eval (car (get symbol 'saved-value))))) | |
105 (t | |
106 (set-default symbol (eval value))))) | |
107 | |
108 (defun custom-declare-variable (symbol value doc &rest args) | |
109 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." | |
110 ;; Remember the standard setting. | |
111 (put symbol 'standard-value (list value)) | |
112 ;; Maybe this option was rogue in an earlier version. It no longer is. | |
113 (when (eq (get symbol 'force-value) 'rogue) | |
114 ;; It no longer is. | |
115 (put symbol 'force-value nil)) | |
116 (when doc | |
117 (put symbol 'variable-documentation doc)) | |
118 (let ((initialize 'custom-initialize-reset) | |
119 (requests nil)) | |
120 (while args | |
121 (let ((arg (car args))) | |
122 (setq args (cdr args)) | |
123 (check-argument-type 'keywordp arg) | |
124 (let ((keyword arg) | |
125 (value (car args))) | |
126 (unless args | |
127 (signal 'error (list "Keyword is missing an argument" keyword))) | |
128 (setq args (cdr args)) | |
129 (cond ((eq keyword :initialize) | |
130 (setq initialize value)) | |
131 ((eq keyword :set) | |
132 (put symbol 'custom-set value)) | |
133 ((eq keyword :get) | |
134 (put symbol 'custom-get value)) | |
135 ((eq keyword :require) | |
136 (setq requests (cons value requests))) | |
137 ((eq keyword :type) | |
138 (put symbol 'custom-type value)) | |
139 ((eq keyword :options) | |
140 (if (get symbol 'custom-options) | |
141 ;; Slow safe code to avoid duplicates. | |
142 (mapc (lambda (option) | |
143 (custom-add-option symbol option)) | |
144 value) | |
145 ;; Fast code for the common case. | |
146 (put symbol 'custom-options (copy-sequence value)))) | |
147 (t | |
148 (custom-handle-keyword symbol keyword value | |
149 'custom-variable)))))) | |
150 (put symbol 'custom-requests requests) | |
151 ;; Do the actual initialization. | |
152 (funcall initialize symbol value)) | |
153 ;; #### This is a rough equivalent of LOADHIST_ATTACH. However, | |
154 ;; LOADHIST_ATTACH also checks for `initialized'. | |
155 (push symbol current-load-list) | |
156 (run-hooks 'custom-define-hook) | |
157 symbol) | |
158 | |
159 (defmacro defcustom (symbol value doc &rest args) | |
160 "Declare SYMBOL as a customizable variable that defaults to VALUE. | |
161 DOC is the variable documentation. | |
162 | |
163 Neither SYMBOL nor VALUE needs to be quoted. | |
164 If SYMBOL is not already bound, initialize it to VALUE. | |
165 The remaining arguments should have the form | |
166 | |
167 [KEYWORD VALUE]... | |
168 | |
169 The following KEYWORD's are defined: | |
170 | |
171 :type VALUE should be a widget type for editing the symbols value. | |
172 The default is `sexp'. | |
173 :options VALUE should be a list of valid members of the widget type. | |
174 :group VALUE should be a customization group. | |
175 Add SYMBOL to that group. | |
176 :initialize VALUE should be a function used to initialize the | |
177 variable. It takes two arguments, the symbol and value | |
178 given in the `defcustom' call. The default is | |
179 `custom-initialize-set' | |
180 :set VALUE should be a function to set the value of the symbol. | |
181 It takes two arguments, the symbol to set and the value to | |
182 give it. The default is `set-default'. | |
183 :get VALUE should be a function to extract the value of symbol. | |
184 The function takes one argument, a symbol, and should return | |
185 the current value for that symbol. The default is | |
186 `default-value'. | |
187 :require VALUE should be a feature symbol. Each feature will be | |
188 required after initialization, of the the user have saved this | |
189 option. | |
190 | |
191 Read the section about customization in the Emacs Lisp manual for more | |
192 information." | |
193 `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)) | |
194 | |
195 ;;; The `defface' Macro. | |
196 | |
197 (defmacro defface (face spec doc &rest args) | |
198 "Declare FACE as a customizable face that defaults to SPEC. | |
199 FACE does not need to be quoted. | |
200 | |
201 Third argument DOC is the face documentation. | |
202 | |
203 If FACE has been set with `custom-set-face', set the face attributes | |
204 as specified by that function, otherwise set the face attributes | |
205 according to SPEC. | |
206 | |
207 The remaining arguments should have the form | |
208 | |
209 [KEYWORD VALUE]... | |
210 | |
211 The following KEYWORDs are defined: | |
212 | |
213 :group VALUE should be a customization group. | |
214 Add FACE to that group. | |
215 | |
216 SPEC should be an alist of the form ((DISPLAY ATTS)...). | |
217 | |
218 ATTS is a list of face attributes and their values. The possible | |
219 attributes are defined in the variable `custom-face-attributes'. | |
220 | |
221 The ATTS of the first entry in SPEC where the DISPLAY matches the | |
222 frame should take effect in that frame. DISPLAY can either be the | |
223 symbol t, which will match all frames, or an alist of the form | |
224 \((REQ ITEM...)...) | |
225 | |
226 For the DISPLAY to match a FRAME, the REQ property of the frame must | |
227 match one of the ITEM. The following REQ are defined: | |
228 | |
229 `type' (the value of `window-system') | |
230 Should be one of `x' or `tty'. | |
231 | |
232 `class' (the frame's color support) | |
233 Should be one of `color', `grayscale', or `mono'. | |
234 | |
235 `background' (what color is used for the background text) | |
236 Should be one of `light' or `dark'. | |
237 | |
238 Read the section about customization in the Emacs Lisp manual for more | |
239 information." | |
240 `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) | |
241 | |
242 ;;; The `defgroup' Macro. | |
243 | |
244 (defun custom-declare-group (symbol members doc &rest args) | |
245 "Like `defgroup', but SYMBOL is evaluated as a normal argument." | |
246 (while members | |
247 (apply 'custom-add-to-group symbol (car members)) | |
248 (pop members)) | |
249 (put symbol 'custom-group (nconc members (get symbol 'custom-group))) | |
250 (when doc | |
251 (put symbol 'group-documentation doc)) | |
252 (while args | |
253 (let ((arg (car args))) | |
254 (setq args (cdr args)) | |
255 (check-argument-type 'keywordp arg) | |
256 (let ((keyword arg) | |
257 (value (car args))) | |
258 (unless args | |
259 (signal 'error (list "Keyword is missing an argument" keyword))) | |
260 (setq args (cdr args)) | |
261 (cond ((eq keyword :prefix) | |
262 (put symbol 'custom-prefix value)) | |
263 (t | |
264 (custom-handle-keyword symbol keyword value | |
265 'custom-group)))))) | |
266 (run-hooks 'custom-define-hook) | |
267 symbol) | |
268 | |
269 (defmacro defgroup (symbol members doc &rest args) | |
270 "Declare SYMBOL as a customization group containing MEMBERS. | |
271 SYMBOL does not need to be quoted. | |
272 | |
273 Third arg DOC is the group documentation. | |
274 | |
275 MEMBERS should be an alist of the form ((NAME WIDGET)...) where NAME | |
276 is a symbol and WIDGET is a widget for editing that symbol. Useful | |
277 widgets are `custom-variable' for editing variables, `custom-face' for | |
278 edit faces, and `custom-group' for editing groups. | |
279 | |
280 The remaining arguments should have the form | |
281 | |
282 [KEYWORD VALUE]... | |
283 | |
284 The following KEYWORD's are defined: | |
285 | |
286 :group VALUE should be a customization group. | |
287 Add SYMBOL to that group. | |
288 | |
289 Read the section about customization in the Emacs Lisp manual for more | |
290 information." | |
291 `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) | |
292 | |
293 (defvar custom-group-hash-table (make-hash-table :size 300 :test 'eq) | |
294 "Hash-table of non-empty groups.") | |
295 | |
296 (defun custom-add-to-group (group option widget) | |
297 "To existing GROUP add a new OPTION of type WIDGET. | |
298 If there already is an entry for that option, overwrite it." | |
299 (let* ((members (get group 'custom-group)) | |
300 (old (assq option members))) | |
301 (if old | |
302 (setcar (cdr old) widget) | |
303 (put group 'custom-group (nconc members (list (list option widget)))))) | |
304 (puthash group t custom-group-hash-table)) | |
305 | |
306 ;;; Properties. | |
307 | |
308 (defun custom-handle-all-keywords (symbol args type) | |
309 "For customization option SYMBOL, handle keyword arguments ARGS. | |
310 Third argument TYPE is the custom option type." | |
311 (while args | |
312 (let ((arg (car args))) | |
313 (setq args (cdr args)) | |
314 (check-argument-type 'keywordp arg) | |
315 (let ((keyword arg) | |
316 (value (car args))) | |
317 (unless args | |
318 (signal 'error (list "Keyword is missing an argument" keyword))) | |
319 (setq args (cdr args)) | |
320 (custom-handle-keyword symbol keyword value type))))) | |
321 | |
322 (defun custom-handle-keyword (symbol keyword value type) | |
323 "For customization option SYMBOL, handle KEYWORD with VALUE. | |
324 Fourth argument TYPE is the custom option type." | |
325 (cond ((eq keyword :group) | |
326 (custom-add-to-group value symbol type)) | |
327 ((eq keyword :version) | |
328 (custom-add-version symbol value)) | |
329 ((eq keyword :link) | |
330 (custom-add-link symbol value)) | |
331 ((eq keyword :load) | |
332 (custom-add-load symbol value)) | |
333 ((eq keyword :tag) | |
334 (put symbol 'custom-tag value)) | |
335 (t | |
336 (signal 'error (list "Unknown keyword" keyword))))) | |
337 | |
338 (defun custom-add-option (symbol option) | |
339 "To the variable SYMBOL add OPTION. | |
340 | |
341 If SYMBOL is a hook variable, OPTION should be a hook member. | |
342 For other types variables, the effect is undefined." | |
343 (let ((options (get symbol 'custom-options))) | |
344 (unless (member option options) | |
345 (put symbol 'custom-options (cons option options))))) | |
346 | |
347 (defun custom-add-link (symbol widget) | |
348 "To the custom option SYMBOL add the link WIDGET." | |
349 (let ((links (get symbol 'custom-links))) | |
350 (unless (member widget links) | |
351 (put symbol 'custom-links (cons widget links))))) | |
352 | |
353 (defun custom-add-version (symbol version) | |
354 "To the custom option SYMBOL add the version VERSION." | |
355 (put symbol 'custom-version version)) | |
356 | |
357 (defun custom-add-load (symbol load) | |
358 "To the custom option SYMBOL add the dependency LOAD. | |
359 LOAD should be either a library file name, or a feature name." | |
360 (puthash symbol t custom-group-hash-table) | |
361 (let ((loads (get symbol 'custom-loads))) | |
362 (unless (member load loads) | |
363 (put symbol 'custom-loads (cons load loads))))) | |
364 | |
365 ;;; deftheme macro | |
366 | |
367 (defvar custom-known-themes '(user standard) | |
368 "Themes that have been defthemed.") | |
369 | |
370 ;; #### add strings for group | |
371 ;; #### during bootstrap we cannot use cl-macs stuff | |
372 (defun* custom-define-theme (theme feature &optional doc | |
373 &key short-description immediate variable-reset-string | |
374 variable-set-string face-set-string face-reset-string | |
375 &allow-other-keys) | |
376 (push theme custom-known-themes) | |
377 (put theme 'theme-feature feature) | |
378 (put theme 'theme-documentation doc) | |
379 (if immediate (put theme 'theme-immediate immediate)) | |
380 (if variable-reset-string | |
381 (put theme 'theme-variable-reset-string variable-reset-string )) | |
382 (if variable-set-string | |
383 (put theme 'theme-variable-set-string variable-set-string )) | |
384 (if face-reset-string | |
385 (put theme 'theme-face-reset-string face-reset-string )) | |
386 (if face-set-string | |
387 (put theme 'theme-face-set-string face-set-string )) | |
388 (if short-description | |
389 (put theme 'theme-short-description short-description ))) | |
390 | |
391 (defun custom-make-theme-feature (theme) | |
392 (intern (concat (symbol-name theme) "-theme"))) | |
393 | |
394 (defmacro deftheme (theme &rest body) | |
395 "(deftheme THEME &optional DOC &key KEYWORDS) | |
396 | |
397 Define a theme labeled by SYMBOL THEME. The optional argument DOC is a | |
398 doc string describing the the theme. It is optionally followed by the | |
399 following keyboard arguments | |
400 | |
401 :short-description DESC | |
402 DESC is a short (one line) description of the theme. If not given DOC | |
403 is used. | |
404 :immediate FLAG | |
405 If FLAG is non-nil variables set in this theme are bound | |
406 immediately when loading the theme. | |
407 :variable-set-string VARIABLE_-SET-STRING | |
408 A string used by the UI to indicate that the value takes it | |
409 setting from this theme. It is passed to FORMAT with the | |
410 name of the theme a additional argument. | |
411 If not given, a generic description is used. | |
412 :variable-reset-string VARIABLE-RESET-STRING | |
413 As above but used in the case the variable has been forced to | |
414 the value in this theme. | |
415 :face-set-string FACE-SET-STRING | |
416 :face-reset-string FACE-RESET-STRING | |
417 As above but for faces." | |
418 (let ((feature (custom-make-theme-feature theme))) | |
419 `(custom-define-theme (quote ,theme) (quote ,feature) ,@body))) | |
420 | |
421 (defsubst custom-theme-p (theme) | |
422 "Non-nil when THEME has been defined." | |
423 (memq theme custom-known-themes)) | |
424 | |
425 (defsubst custom-check-theme (theme) | |
426 "Check whether THEME is valid and signal an error if NOT" | |
427 (unless (custom-theme-p theme) | |
428 (error "Unknown theme `%s'" theme))) | |
429 | |
430 | |
431 ; #### do we need to deftheme 'user and/or 'standard here to make the | |
432 ; code in cus-edit cleaner?. | |
433 | |
434 ;;; Initializing. | |
435 | |
436 (defun custom-push-theme (prop symbol theme mode value) | |
437 (let ((old (get symbol prop))) | |
438 (if (eq (car-safe (car-safe old)) theme) | |
439 (setq old (cdr old))) | |
440 (put symbol prop (cons (list theme mode value) old)))) | |
441 | |
442 (defun custom-set-variables (&rest args) | |
443 "Initialize variables according to user preferences. | |
444 The settings are registered as theme `user'. | |
445 The arguments should be a list where each entry has the form: | |
446 | |
447 (SYMBOL VALUE [NOW [REQUEST [COMMENT]]]) | |
448 | |
449 The unevaluated VALUE is stored as the saved value for SYMBOL. | |
450 If NOW is present and non-nil, VALUE is also evaluated and bound as | |
451 the default value for the SYMBOL. | |
452 REQUEST is a list of features we must 'require for SYMBOL. | |
453 COMMENT is a comment string about SYMBOL." | |
454 (apply 'custom-theme-set-variables 'user args)) | |
455 | |
456 (defun custom-theme-set-variables (theme &rest args) | |
457 "Initialize variables according to settings specified by args. | |
458 Records the settings as belonging to THEME. | |
459 | |
460 See `custom-set-variables' for a description of the arguments ARGS." | |
461 (custom-check-theme theme) | |
462 (let ((immediate (get theme 'theme-immediate))) | |
463 (while args * etc/custom/example-themes/example-theme.el: | |
464 (let ((entry (car args))) | |
465 (if (listp entry) | |
466 (let* ((symbol (nth 0 entry)) | |
467 (value (nth 1 entry)) | |
468 (now (nth 2 entry)) | |
469 (requests (nth 3 entry)) | |
470 (comment (nth 4 entry)) | |
471 (set (or (get symbol 'custom-set) 'set-default))) | |
472 (put symbol 'saved-value (list value)) | |
473 (custom-push-theme 'theme-value symbol theme 'set value) | |
474 (put symbol 'saved-variable-comment comment) | |
475 (cond ((or now immediate) | |
476 ;; Rogue variable, set it now. | |
477 (put symbol 'force-value (if now 'rogue 'immediate)) | |
478 (funcall set symbol (eval value))) | |
479 ((default-boundp symbol) | |
480 ;; Something already set this, overwrite it. | |
481 (funcall set symbol (eval value)))) | |
482 (and (or now (default-boundp symbol)) | |
483 (put symbol 'variable-comment comment)) | |
484 (when requests | |
485 (put symbol 'custom-requests requests) | |
486 (mapc 'require requests)) | |
487 (setq args (cdr args))) | |
488 ;; Old format, a plist of SYMBOL VALUE pairs. | |
489 (message "Warning: old format `custom-set-variables'") | |
490 (ding) | |
491 (sit-for 2) | |
492 (let ((symbol (nth 0 args)) | |
493 (value (nth 1 args))) | |
494 (put symbol 'saved-value (list value)) | |
495 (custom-push-theme 'theme-value symbol theme 'set value)) | |
496 (setq args (cdr (cdr args)))))))) | |
497 | |
498 (defvar custom-loaded-themes nil | |
499 "Themes in the order they are loaded.") | |
500 | |
501 (defun custom-theme-loaded-p (theme) | |
502 "Return non-nil when THEME has been loaded." | |
503 (memq theme custom-loaded-themes)) | |
504 | |
505 (defun provide-theme (theme) | |
506 "Indicate that this file provides THEME." | |
507 (custom-check-theme theme) | |
508 (provide (get theme 'theme-feature)) | |
509 (push theme custom-loaded-themes)) | |
510 | |
511 (defun require-theme (theme &optional soft) | |
512 "Try to load a theme by requiring its feature." | |
513 ;; Note we do no check for validity of the theme here. | |
514 ;; This allows to pull in themes by a file-name convention | |
515 (require (get theme 'theme-feature (custom-make-theme-feature theme)))) | |
516 | |
517 (defun custom-do-theme-reset (theme) | |
518 ; #### untested! slow! | |
519 (let (spec-list) | |
520 (mapatoms (lambda (symbol) | |
521 (setq spec-list (get symbol 'theme-value)) | |
522 (when spec-list | |
523 (setq spec-list (delete-if (lambda (elt) | |
524 (eq (car elt) theme)) | |
525 spec-list)) | |
526 (put symbol 'theme-value spec-list) | |
527 (custom-theme-reset-internal symbol 'user)) | |
528 (setq spec-list (get symbol 'theme-face)) | |
529 (when spec-list | |
530 (setq spec-list (delete-if (lambda (elt) | |
531 (eq (car elt) theme)) | |
532 spec-list)) | |
533 (put symbol 'theme-face spec-list) | |
534 (custom-theme-reset-internal-face symbol 'user)))))) | |
535 | |
536 (defun custom-theme-load-themes (by-theme &rest body) | |
537 "Load the themes specified by BODY and record them as required by | |
538 theme BY-THEME. BODY is a secuence of | |
539 - a SYMBOL | |
540 require the theme SYMBOL | |
541 - a list (reset THEME) | |
542 Undo all the settings made by THEME. | |
543 - a list (hidden THEME) | |
544 require the THEME but hide it from the user." | |
545 (custom-check-theme by-theme) | |
546 (dolist (theme body) | |
547 (cond ((and (consp theme) (eq (car theme) 'reset)) | |
548 (custom-do-theme-reset (cadr theme))) | |
549 ((and (consp theme) (eq (car theme) 'hidden)) | |
550 (require-theme (cadr theme)) | |
551 (unless (custom-theme-loaded-p (cadr theme)) | |
552 (put (cadr theme) 'theme-hidden t))) | |
553 (t | |
554 (require-theme theme) | |
555 (remprop theme 'theme-hidden))) | |
556 (push theme (get by-theme 'theme-loads-themes)))) | |
557 | |
558 (defun custom-load-themes (&rest body) | |
559 "Load themes for the USER theme as specified by BODY. | |
560 | |
561 BODY is as with custom-theme-load-themes." | |
562 (apply #'custom-theme-load-themes 'user body)) | |
563 | |
564 | |
565 | |
566 | |
567 (defsubst copy-upto-last (elt list) | |
568 "Copy all the elements of the list upto the last occurence of elt" | |
569 ;; Is it faster to do more work in C than to do less in elisp? | |
570 (nreverse (cdr (member elt (reverse list))))) | |
571 | |
572 (defun custom-theme-value (theme theme-spec-list) | |
573 "Determine the value for THEME defined by THEME-SPEC-LIST. | |
574 Returns (list value) if found. Nil otherwise." | |
575 ;; Note we do _NOT_ singal an error if the theme is unkown | |
576 ;; it might have gone away without the user knowing. | |
577 (let ((theme-or-lower (memq theme (cons 'user custom-loaded-themes))) | |
578 value) | |
579 (mapc #'(lambda (theme-spec) | |
580 (when (member (car theme-spec) theme-or-lower) | |
581 (setq value (cdr theme-spec)) | |
582 ;; We need to continue because if theme =A and we found | |
583 ;; B then if the load order is B A C B | |
584 ;; we actually want the value in C. | |
585 (setq theme-or-lower (copy-upto-last (car theme-spec) | |
586 theme-or-lower)) | |
587 ;; We could should circuit if this is now nil. | |
588 )) | |
589 theme-spec-list) | |
590 (if value | |
591 (if (eq (car value) 'set) | |
592 (list (cadr value)) | |
593 ;; Yet another reset spec. car value = reset | |
594 (custom-theme-value (cadr value) theme-spec-list))))) | |
595 | |
596 | |
597 (defun custom-theme-variable-value (variable theme) | |
598 "Return (list value) value of VARIABLE in THEME if the THEME modifies the | |
599 VARIABLE. Nil otherwise." | |
600 (custom-theme-value theme (get variable 'theme-value))) | |
601 | |
602 (defun custom-theme-reset-internal (symbol to-theme) | |
603 (let ((value (custom-theme-variable-value symbol to-theme)) | |
604 was-in-theme) | |
605 (setq was-in-theme value) | |
606 (setq value (or value (get symbol 'standard-value))) | |
607 (when value | |
608 (put symbol 'saved-value was-in-theme) | |
609 (if (or (get 'force-value symbol) (default-boundp symbol)) | |
610 (funcall (get symbol 'custom-set 'set-default) symbol | |
611 (eval (car value))))) | |
612 value)) | |
613 | |
614 | |
615 (defun custom-theme-reset-variables (theme &rest args) | |
616 "Reset the value of the variables to values previously defined. | |
617 Assosiate this setting with THEME. | |
618 | |
619 ARGS is a list of lists of the form | |
620 | |
621 (variable to-theme) | |
622 | |
623 This means reset variable to its value in to-theme." | |
624 (custom-check-theme theme) | |
625 (mapc #'(lambda (arg) | |
626 (apply #'custom-theme-reset-internal arg) | |
627 (custom-push-theme 'theme-value (car arg) theme 'reset (cadr arg))) | |
628 args)) | |
629 | |
630 (defun custom-reset-variables (&rest args) | |
631 "Reset the value of the variables to values previously defined. | |
632 Assosiate this setting with the `user' theme. | |
633 | |
634 The ARGS are as in `custom-theme-reset-variables'." | |
635 (apply #'custom-theme-reset-variables 'user args)) | |
636 | |
637 | |
638 ;;; The End. | |
639 | |
640 (provide 'custom) | |
641 | |
642 ;; custom.el ends here |