Mercurial > hg > xemacs-beta

comparison lisp/custom.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 8626e4521993
children 2f8bb876ab1d
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
1 ;;; custom.el -- Tools for declaring and initializing options. 1 ;;; custom.el -- Tools for declaring and initializing options.
2 2
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
4 4
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> 6 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
7 ;; Keywords: help, faces, dumped 7 ;; Keywords: help, faces, dumped
8 ;; Version: 1.9960-x 8 ;; Version: 1.9960-x
9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
10 10
11 ;; This file is part of XEmacs. 11 ;; This file is part of XEmacs.
29 29
30 ;; This file is dumped with XEmacs. 30 ;; This file is dumped with XEmacs.
31 31
32 ;; This file only contain the code needed to declare and initialize 32 ;; This file only contain the code needed to declare and initialize
33 ;; user options. The code to customize options is autoloaded from 33 ;; user options. The code to customize options is autoloaded from
34 ;; `cus-edit.el'. 34 ;; `cus-edit.el'.
35 ;; 35 ;;
36 ;; The code implementing face declarations is in `cus-face.el' 36 ;; The code implementing face declarations is in `cus-face.el'
37 37
38 ;;; Code: 38 ;;; Code:
39
40 (eval-when-compile
41 (load "cl-macs"))
42
43 (if (not (fboundp 'defun*))
44 (autoload 'defun* "cl-macs"))
39 45
40 (require 'widget) 46 (require 'widget)
41 47
42 (defvar custom-define-hook nil 48 (defvar custom-define-hook nil
43 ;; Customize information for this option is in `cus-edit.el'. 49 ;; Customize information for this option is in `cus-edit.el'.
53 Otherwise, VALUE will be evaluated and used as the default binding for 59 Otherwise, VALUE will be evaluated and used as the default binding for
54 symbol." 60 symbol."
55 (unless (default-boundp symbol) 61 (unless (default-boundp symbol)
56 ;; Use the saved value if it exists, otherwise the standard setting. 62 ;; Use the saved value if it exists, otherwise the standard setting.
57 (set-default symbol (if (get symbol 'saved-value) 63 (set-default symbol (if (get symbol 'saved-value)
58 (eval (car (get symbol 'saved-value))) 64 (eval (car (get symbol 'saved-value)))
59 (eval value))))) 65 (eval value)))))
60 66
61 (defun custom-initialize-set (symbol value) 67 (defun custom-initialize-set (symbol value)
62 "Initialize SYMBOL with VALUE. 68 "Initialize SYMBOL with VALUE.
63 Like `custom-initialize-default', but use the function specified by 69 Like `custom-initialize-default', but use the function specified by
64 `:set' to initialize SYMBOL." 70 `:set' to initialize SYMBOL."
65 (unless (default-boundp symbol) 71 (unless (default-boundp symbol)
66 (funcall (or (get symbol 'custom-set) 'set-default) 72 (funcall (or (get symbol 'custom-set) 'set-default)
67 symbol 73 symbol
68 (if (get symbol 'saved-value) 74 (if (get symbol 'saved-value)
69 (eval (car (get symbol 'saved-value))) 75 (eval (car (get symbol 'saved-value)))
70 (eval value))))) 76 (eval value)))))
71 77
72 (defun custom-initialize-reset (symbol value) 78 (defun custom-initialize-reset (symbol value)
73 "Initialize SYMBOL with VALUE. 79 "Initialize SYMBOL with VALUE.
74 Like `custom-initialize-set', but use the function specified by 80 Like `custom-initialize-set', but use the function specified by
75 `:get' to reinitialize SYMBOL if it is already bound." 81 `:get' to reinitialize SYMBOL if it is already bound."
76 (funcall (or (get symbol 'custom-set) 'set-default) 82 (funcall (or (get symbol 'custom-set) 'set-default)
77 symbol 83 symbol
78 (cond ((default-boundp symbol) 84 (cond ((default-boundp symbol)
79 (funcall (or (get symbol 'custom-get) 'default-value) 85 (funcall (or (get symbol 'custom-get) 'default-value)
80 symbol)) 86 symbol))
81 ((get symbol 'saved-value) 87 ((get symbol 'saved-value)
82 (eval (car (get symbol 'saved-value)))) 88 (eval (car (get symbol 'saved-value))))
83 (t 89 (t
84 (eval value))))) 90 (eval value)))))
85 91
86 (defun custom-initialize-changed (symbol value) 92 (defun custom-initialize-changed (symbol value)
87 "Initialize SYMBOL with VALUE. 93 "Initialize SYMBOL with VALUE.
88 Like `custom-initialize-reset', but only use the `:set' function if the 94 Like `custom-initialize-reset', but only use the `:set' function if the
89 not using the standard setting. Otherwise, use the `set-default'." 95 not using the standard setting. Otherwise, use the `set-default'."
90 (cond ((default-boundp symbol) 96 (cond ((default-boundp symbol)
91 (funcall (or (get symbol 'custom-set) 'set-default) 97 (funcall (or (get symbol 'custom-set) 'set-default)
92 symbol 98 symbol
93 (funcall (or (get symbol 'custom-get) 'default-value) 99 (funcall (or (get symbol 'custom-get) 'default-value)
94 symbol))) 100 symbol)))
95 ((get symbol 'saved-value) 101 ((get symbol 'saved-value)
96 (funcall (or (get symbol 'custom-set) 'set-default) 102 (funcall (or (get symbol 'custom-set) 'set-default)
97 symbol 103 symbol
98 (eval (car (get symbol 'saved-value))))) 104 (eval (car (get symbol 'saved-value)))))
99 (t 105 (t
100 (set-default symbol (eval value))))) 106 (set-default symbol (eval value)))))
101 107
102 (defun custom-declare-variable (symbol value doc &rest args) 108 (defun custom-declare-variable (symbol value doc &rest args)
103 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." 109 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
104 ;; Remember the standard setting. 110 ;; Remember the standard setting.
105 (put symbol 'standard-value (list value)) 111 (put symbol 'standard-value (list value))
106 ;; Maybe this option was rogue in an earlier version. It no longer is. 112 ;; Maybe this option was rogue in an earlier version. It no longer is.
107 (when (get symbol 'force-value) 113 (when (eq (get symbol 'force-value) 'rogue)
108 ;; It no longer is. 114 ;; It no longer is.
109 (put symbol 'force-value nil)) 115 (put symbol 'force-value nil))
110 (when doc 116 (when doc
111 (put symbol 'variable-documentation doc)) 117 (put symbol 'variable-documentation doc))
112 (let ((initialize 'custom-initialize-reset) 118 (let ((initialize 'custom-initialize-reset)
113 (requests nil)) 119 (requests nil))
114 (while args 120 (while args
115 (let ((arg (car args))) 121 (let ((arg (car args)))
116 (setq args (cdr args)) 122 (setq args (cdr args))
117 (check-argument-type 'keywordp arg) 123 (check-argument-type 'keywordp arg)
118 (let ((keyword arg) 124 (let ((keyword arg)
119 (value (car args))) 125 (value (car args)))
120 (unless args 126 (unless args
121 (signal 'error (list "Keyword is missing an argument" keyword))) 127 (signal 'error (list "Keyword is missing an argument" keyword)))
122 (setq args (cdr args)) 128 (setq args (cdr args))
123 (cond ((eq keyword :initialize) 129 (cond ((eq keyword :initialize)
124 (setq initialize value)) 130 (setq initialize value))
125 ((eq keyword :set) 131 ((eq keyword :set)
126 (put symbol 'custom-set value)) 132 (put symbol 'custom-set value))
127 ((eq keyword :get) 133 ((eq keyword :get)
128 (put symbol 'custom-get value)) 134 (put symbol 'custom-get value))
129 ((eq keyword :require) 135 ((eq keyword :require)
130 (setq requests (cons value requests))) 136 (setq requests (cons value requests)))
131 ((eq keyword :type) 137 ((eq keyword :type)
132 (put symbol 'custom-type value)) 138 (put symbol 'custom-type value))
133 ((eq keyword :options) 139 ((eq keyword :options)
134 (if (get symbol 'custom-options) 140 (if (get symbol 'custom-options)
135 ;; Slow safe code to avoid duplicates. 141 ;; Slow safe code to avoid duplicates.
136 (mapc (lambda (option) 142 (mapc (lambda (option)
137 (custom-add-option symbol option)) 143 (custom-add-option symbol option))
138 value) 144 value)
139 ;; Fast code for the common case. 145 ;; Fast code for the common case.
140 (put symbol 'custom-options (copy-sequence value)))) 146 (put symbol 'custom-options (copy-sequence value))))
141 (t 147 (t
142 (custom-handle-keyword symbol keyword value 148 (custom-handle-keyword symbol keyword value
143 'custom-variable)))))) 149 'custom-variable))))))
144 (put symbol 'custom-requests requests) 150 (put symbol 'custom-requests requests)
145 ;; Do the actual initialization. 151 ;; Do the actual initialization.
146 (funcall initialize symbol value)) 152 (funcall initialize symbol value))
147 ;; #### This is a rough equivalent of LOADHIST_ATTACH. However, 153 ;; #### This is a rough equivalent of LOADHIST_ATTACH. However,
148 ;; LOADHIST_ATTACH also checks for `initialized'. 154 ;; LOADHIST_ATTACH also checks for `initialized'.
156 162
157 Neither SYMBOL nor VALUE needs to be quoted. 163 Neither SYMBOL nor VALUE needs to be quoted.
158 If SYMBOL is not already bound, initialize it to VALUE. 164 If SYMBOL is not already bound, initialize it to VALUE.
159 The remaining arguments should have the form 165 The remaining arguments should have the form
160 166
161 [KEYWORD VALUE]... 167 [KEYWORD VALUE]...
162 168
163 The following KEYWORD's are defined: 169 The following KEYWORD's are defined:
164 170
165 :type VALUE should be a widget type for editing the symbols value. 171 :type VALUE should be a widget type for editing the symbols value.
166 The default is `sexp'. 172 The default is `sexp'.
167 :options VALUE should be a list of valid members of the widget type. 173 :options VALUE should be a list of valid members of the widget type.
168 :group VALUE should be a customization group. 174 :group VALUE should be a customization group.
169 Add SYMBOL to that group. 175 Add SYMBOL to that group.
170 :initialize VALUE should be a function used to initialize the 176 :initialize VALUE should be a function used to initialize the
171 variable. It takes two arguments, the symbol and value 177 variable. It takes two arguments, the symbol and value
172 given in the `defcustom' call. The default is 178 given in the `defcustom' call. The default is
173 `custom-initialize-set' 179 `custom-initialize-set'
174 :set VALUE should be a function to set the value of the symbol. 180 :set VALUE should be a function to set the value of the symbol.
175 It takes two arguments, the symbol to set and the value to 181 It takes two arguments, the symbol to set and the value to
176 give it. The default is `set-default'. 182 give it. The default is `set-default'.
177 :get VALUE should be a function to extract the value of symbol. 183 :get VALUE should be a function to extract the value of symbol.
178 The function takes one argument, a symbol, and should return 184 The function takes one argument, a symbol, and should return
179 the current value for that symbol. The default is 185 the current value for that symbol. The default is
180 `default-value'. 186 `default-value'.
181 :require VALUE should be a feature symbol. Each feature will be 187 :require VALUE should be a feature symbol. Each feature will be
182 required after initialization, of the the user have saved this 188 required after initialization, of the the user have saved this
183 option. 189 option.
184 190
185 Read the section about customization in the Emacs Lisp manual for more 191 Read the section about customization in the Emacs Lisp manual for more
186 information." 192 information."
187 `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)) 193 `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))
188 194
235 241
236 ;;; The `defgroup' Macro. 242 ;;; The `defgroup' Macro.
237 243
238 (defun custom-declare-group (symbol members doc &rest args) 244 (defun custom-declare-group (symbol members doc &rest args)
239 "Like `defgroup', but SYMBOL is evaluated as a normal argument." 245 "Like `defgroup', but SYMBOL is evaluated as a normal argument."
240 (while members 246 (while members
241 (apply 'custom-add-to-group symbol (car members)) 247 (apply 'custom-add-to-group symbol (car members))
242 (pop members)) 248 (pop members))
243 (put symbol 'custom-group (nconc members (get symbol 'custom-group))) 249 (put symbol 'custom-group (nconc members (get symbol 'custom-group)))
244 (when doc 250 (when doc
245 (put symbol 'group-documentation doc)) 251 (put symbol 'group-documentation doc))
246 (while args 252 (while args
247 (let ((arg (car args))) 253 (let ((arg (car args)))
248 (setq args (cdr args)) 254 (setq args (cdr args))
249 (check-argument-type 'keywordp arg) 255 (check-argument-type 'keywordp arg)
250 (let ((keyword arg) 256 (let ((keyword arg)
251 (value (car args))) 257 (value (car args)))
252 (unless args 258 (unless args
253 (signal 'error (list "Keyword is missing an argument" keyword))) 259 (signal 'error (list "Keyword is missing an argument" keyword)))
254 (setq args (cdr args)) 260 (setq args (cdr args))
255 (cond ((eq keyword :prefix) 261 (cond ((eq keyword :prefix)
256 (put symbol 'custom-prefix value)) 262 (put symbol 'custom-prefix value))
257 (t 263 (t
258 (custom-handle-keyword symbol keyword value 264 (custom-handle-keyword symbol keyword value
259 'custom-group)))))) 265 'custom-group))))))
260 (run-hooks 'custom-define-hook) 266 (run-hooks 'custom-define-hook)
261 symbol) 267 symbol)
262 268
263 (defmacro defgroup (symbol members doc &rest args) 269 (defmacro defgroup (symbol members doc &rest args)
264 "Declare SYMBOL as a customization group containing MEMBERS. 270 "Declare SYMBOL as a customization group containing MEMBERS.
271 widgets are `custom-variable' for editing variables, `custom-face' for 277 widgets are `custom-variable' for editing variables, `custom-face' for
272 edit faces, and `custom-group' for editing groups. 278 edit faces, and `custom-group' for editing groups.
273 279
274 The remaining arguments should have the form 280 The remaining arguments should have the form
275 281
276 [KEYWORD VALUE]... 282 [KEYWORD VALUE]...
277 283
278 The following KEYWORD's are defined: 284 The following KEYWORD's are defined:
279 285
280 :group VALUE should be a customization group. 286 :group VALUE should be a customization group.
281 Add SYMBOL to that group. 287 Add SYMBOL to that group.
289 295
290 (defun custom-add-to-group (group option widget) 296 (defun custom-add-to-group (group option widget)
291 "To existing GROUP add a new OPTION of type WIDGET. 297 "To existing GROUP add a new OPTION of type WIDGET.
292 If there already is an entry for that option, overwrite it." 298 If there already is an entry for that option, overwrite it."
293 (let* ((members (get group 'custom-group)) 299 (let* ((members (get group 'custom-group))
294 (old (assq option members))) 300 (old (assq option members)))
295 (if old 301 (if old
296 (setcar (cdr old) widget) 302 (setcar (cdr old) widget)
297 (put group 'custom-group (nconc members (list (list option widget)))))) 303 (put group 'custom-group (nconc members (list (list option widget))))))
298 (puthash group t custom-group-hash-table)) 304 (puthash group t custom-group-hash-table))
299 305
300 ;;; Properties. 306 ;;; Properties.
301 307
302 (defun custom-handle-all-keywords (symbol args type) 308 (defun custom-handle-all-keywords (symbol args type)
303 "For customization option SYMBOL, handle keyword arguments ARGS. 309 "For customization option SYMBOL, handle keyword arguments ARGS.
304 Third argument TYPE is the custom option type." 310 Third argument TYPE is the custom option type."
305 (while args 311 (while args
306 (let ((arg (car args))) 312 (let ((arg (car args)))
307 (setq args (cdr args)) 313 (setq args (cdr args))
308 (check-argument-type 'keywordp arg) 314 (check-argument-type 'keywordp arg)
309 (let ((keyword arg) 315 (let ((keyword arg)
310 (value (car args))) 316 (value (car args)))
311 (unless args 317 (unless args
312 (signal 'error (list "Keyword is missing an argument" keyword))) 318 (signal 'error (list "Keyword is missing an argument" keyword)))
313 (setq args (cdr args)) 319 (setq args (cdr args))
314 (custom-handle-keyword symbol keyword value type))))) 320 (custom-handle-keyword symbol keyword value type)))))
315 321
316 (defun custom-handle-keyword (symbol keyword value type) 322 (defun custom-handle-keyword (symbol keyword value type)
317 "For customization option SYMBOL, handle KEYWORD with VALUE. 323 "For customization option SYMBOL, handle KEYWORD with VALUE.
318 Fourth argument TYPE is the custom option type." 324 Fourth argument TYPE is the custom option type."
319 (cond ((eq keyword :group) 325 (cond ((eq keyword :group)
320 (custom-add-to-group value symbol type)) 326 (custom-add-to-group value symbol type))
321 ((eq keyword :version) 327 ((eq keyword :version)
322 (custom-add-version symbol value)) 328 (custom-add-version symbol value))
323 ((eq keyword :link) 329 ((eq keyword :link)
324 (custom-add-link symbol value)) 330 (custom-add-link symbol value))
325 ((eq keyword :load) 331 ((eq keyword :load)
326 (custom-add-load symbol value)) 332 (custom-add-load symbol value))
327 ((eq keyword :tag) 333 ((eq keyword :tag)
328 (put symbol 'custom-tag value)) 334 (put symbol 'custom-tag value))
329 (t 335 (t
330 (signal 'error (list "Unknown keyword" keyword))))) 336 (signal 'error (list "Unknown keyword" keyword)))))
331 337
332 (defun custom-add-option (symbol option) 338 (defun custom-add-option (symbol option)
333 "To the variable SYMBOL add OPTION. 339 "To the variable SYMBOL add OPTION.
334 340
335 If SYMBOL is a hook variable, OPTION should be a hook member. 341 If SYMBOL is a hook variable, OPTION should be a hook member.
354 (puthash symbol t custom-group-hash-table) 360 (puthash symbol t custom-group-hash-table)
355 (let ((loads (get symbol 'custom-loads))) 361 (let ((loads (get symbol 'custom-loads)))
356 (unless (member load loads) 362 (unless (member load loads)
357 (put symbol 'custom-loads (cons load loads))))) 363 (put symbol 'custom-loads (cons load loads)))))
358 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
359 ;;; Initializing. 434 ;;; Initializing.
360 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
361 (defun custom-set-variables (&rest args) 442 (defun custom-set-variables (&rest args)
362 "Initialize variables according to user preferences. 443 "Initialize variables according to user preferences.
363 444 The settings are registered as theme `user'.
364 The arguments should be a list where each entry has the form: 445 The arguments should be a list where each entry has the form:
365 446
366 (SYMBOL VALUE [NOW]) 447 (SYMBOL VALUE [NOW [REQUEST [COMMENT]]])
367 448
368 The unevaluated VALUE is stored as the saved value for SYMBOL. 449 The unevaluated VALUE is stored as the saved value for SYMBOL.
369 If NOW is present and non-nil, VALUE is also evaluated and bound as 450 If NOW is present and non-nil, VALUE is also evaluated and bound as
370 the default value for the SYMBOL." 451 the default value for the SYMBOL.
371 (while args 452 REQUEST is a list of features we must 'require for SYMBOL.
372 (let ((entry (car args))) 453 COMMENT is a comment string about SYMBOL."
373 (if (listp entry) 454 (apply 'custom-theme-set-variables 'user args))
374 (let* ((symbol (nth 0 entry)) 455
375 (value (nth 1 entry)) 456 (defun custom-theme-set-variables (theme &rest args)
376 (now (nth 2 entry)) 457 "Initialize variables according to settings specified by args.
377 (requests (nth 3 entry)) 458 Records the settings as belonging to THEME.
378 (set (or (get symbol 'custom-set) 'set-default))) 459
379 (put symbol 'saved-value (list value)) 460 See `custom-set-variables' for a description of the arguments ARGS."
380 (cond (now 461 (custom-check-theme theme)
381 ;; Rogue variable, set it now. 462 (let ((immediate (get theme 'theme-immediate)))
382 (put symbol 'force-value t) 463 (while args * etc/custom/example-themes/example-theme.el:
383 (funcall set symbol (eval value))) 464 (let ((entry (car args)))
384 ((default-boundp symbol) 465 (if (listp entry)
385 ;; Something already set this, overwrite it. 466 (let* ((symbol (nth 0 entry))
386 (funcall set symbol (eval value)))) 467 (value (nth 1 entry))
387 (when requests 468 (now (nth 2 entry))
388 (put symbol 'custom-requests requests) 469 (requests (nth 3 entry))
389 (mapc 'require requests)) 470 (comment (nth 4 entry))
390 (setq args (cdr args))) 471 (set (or (get symbol 'custom-set) 'set-default)))
391 ;; Old format, a plist of SYMBOL VALUE pairs. 472 (put symbol 'saved-value (list value))
392 (message "Warning: old format `custom-set-variables'") 473 (custom-push-theme 'theme-value symbol theme 'set value)
393 (ding) 474 (put symbol 'saved-variable-comment comment)
394 (sit-for 2) 475 (cond ((or now immediate)
395 (let ((symbol (nth 0 args)) 476 ;; Rogue variable, set it now.
396 (value (nth 1 args))) 477 (put symbol 'force-value (if now 'rogue 'immediate))
397 (put symbol 'saved-value (list value))) 478 (funcall set symbol (eval value)))
398 (setq args (cdr (cdr args))))))) 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_ signal an error if the theme is unknown
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
399 637
400 ;;; The End. 638 ;;; The End.
401 639
402 (provide 'custom) 640 (provide 'custom)
403 641