Mercurial > hg > xemacs-beta

comparison lisp/custom.el @ 412:697ef44129c6 r21-2-14

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