Mercurial > hg > xemacs-beta

comparison lisp/custom.el @ 2544:b4a8cd0dd8df

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2005-02-03 04:29:32 by ben] behavior ws #1: custom updates cus-dep.el: If a directory has no custom dependencies, write a blank custom-load file rather than deleting the file, so that time-based rebuild checking will work. cus-edit.el: Split out code in custom-load-symbol. Support loading of the new custom-defines file. cus-edit.el: Split long menus. custom.el: Sync with FSF 21.3.
author ben
date Thu, 03 Feb 2005 04:29:33 +0000
parents c9b6a2fec10d
children cef5f57bb9e2
comparison
equal deleted inserted replaced
2543:5e6de1feeafc 2544:b4a8cd0dd8df
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, 1999, 2001, 2002 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: XEmacs Development Group
7 ;; Keywords: help, faces, dumped 7 ;; Keywords: help, faces, dumped
8 ;; Version: 1.9960-x
9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
10 8
11 ;; This file is part of XEmacs. 9 ;; This file is part of XEmacs.
12 10
13 ;; XEmacs is free software; you can redistribute it and/or modify 11 ;; 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 12 ;; it under the terms of the GNU General Public License as published by
23 ;; You should have received a copy of the GNU General Public License 21 ;; 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 22 ;; along with XEmacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
27 25
28 ;;; Synched with: ??? Partially synched to 21.2 by Ben Wing. 26 ;;; Synched with: FSF 21.3.
29 27
30 ;;; Commentary: 28 ;;; Commentary:
31 29
32 ;; This file is dumped with XEmacs. 30 ;; This file is dumped with XEmacs.
33 31
34 ;; This file only contain the code needed to declare and initialize 32 ;;
33 ;; This file only contains the code needed to declare and initialize
35 ;; user options. The code to customize options is autoloaded from 34 ;; user options. The code to customize options is autoloaded from
36 ;; `cus-edit.el'. 35 ;; `cus-edit.el' and is documented in the XEmacs Lisp Reference manual.
37 ;; 36
38 ;; The code implementing face declarations is in `cus-face.el' 37 ;; The code implementing face declarations is in `cus-face.el'.
39 38
40 ;;; Code: 39 ;;; Code:
41 40
42 ;; it is now safe to put the `provide' anywhere. if an error occurs while 41 ;; it is now safe to put the `provide' anywhere. if an error occurs while
43 ;; loading, all provides (and fsets) will be undone. put it first to 42 ;; loading, all provides (and fsets) will be undone. put it first to
44 ;; prevent require/provide loop with custom and cus-face. 43 ;; prevent require/provide loop with custom and cus-face.
45 (provide 'custom) 44 (provide 'custom)
46 45
47 ;; BEGIN SYNC WITH FSF 21.2
48
49 (eval-when-compile 46 (eval-when-compile
50 (load "cl-macs" nil t) 47 (load "cl-macs" nil t)
51 ;; To elude warnings. 48 ;; To elude warnings.
52 (require 'cus-face)) 49 (require 'cus-face))
53 50
57 (require 'widget) 54 (require 'widget)
58 55
59 (defvar custom-define-hook nil 56 (defvar custom-define-hook nil
60 ;; Customize information for this option is in `cus-edit.el'. 57 ;; Customize information for this option is in `cus-edit.el'.
61 "Hook called after defining each customize option.") 58 "Hook called after defining each customize option.")
59
60 (defvar custom-dont-initialize nil
61 "Non-nil means `defcustom' should not initialize the variable.
62 That is used for the sake of `custom-make-dependencies'.
63 Users should not set it.")
64
65 (defvar custom-current-group-alist nil
66 "Alist of (FILE . GROUP) indicating the current group to use for FILE.")
62 67
63 ;;; The `defcustom' Macro. 68 ;;; The `defcustom' Macro.
64 69
65 (defun custom-initialize-default (symbol value) 70 (defun custom-initialize-default (symbol value)
66 "Initialize SYMBOL with VALUE. 71 "Initialize SYMBOL with VALUE.
129 (set-default symbol (eval value))))) 134 (set-default symbol (eval value)))))
130 135
131 (defun custom-declare-variable (symbol default doc &rest args) 136 (defun custom-declare-variable (symbol default doc &rest args)
132 "Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments. 137 "Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments.
133 DEFAULT should be an expression to evaluate to compute the default value, 138 DEFAULT should be an expression to evaluate to compute the default value,
134 not the default value itself." 139 not the default value itself.
135 ;; Remember the standard setting. 140
141 DEFAULT is stored as SYMBOL's value in the standard theme. See
142 `custom-known-themes' for a list of known themes. For backwards
143 compatibility, DEFAULT is also stored in SYMBOL's property
144 `standard-value'. At the same time, SYMBOL's property `force-value' is
145 set to nil, as the value is no longer rogue."
146 ;; Remember the standard setting. The value should be in the standard
147 ;; theme, not in this property. However, his would require changeing
148 ;; the C source of defvar and others as well...
136 (put symbol 'standard-value (list default)) 149 (put symbol 'standard-value (list default))
137 ;; Maybe this option was rogue in an earlier version. It no longer is. 150 ;; Maybe this option was rogue in an earlier version. It no longer is.
138 (when (eq (get symbol 'force-value) 'rogue) 151 (when (eq (get symbol 'force-value) 'rogue)
139 ;; It no longer is. 152 ;; It no longer is.
140 (put symbol 'force-value nil)) 153 (put symbol 'force-value nil))
141 (when doc 154 (when doc
142 (put symbol 'variable-documentation doc)) 155 (put symbol 'variable-documentation doc))
143 (let ((initialize 'custom-initialize-reset) 156 (let ((initialize 'custom-initialize-reset)
144 (requests nil)) 157 (requests nil))
158 (unless (memq :group args)
159 (custom-add-to-group (custom-current-group) symbol 'custom-variable))
145 (while args 160 (while args
146 (let ((arg (car args))) 161 (let ((arg (car args)))
147 (setq args (cdr args)) 162 (setq args (cdr args))
148 (check-argument-type 'keywordp arg) 163 (check-argument-type 'keywordp arg)
149 (let ((keyword arg) 164 (let ((keyword arg)
150 (value (car args))) 165 (value (car args)))
151 (unless args 166 (unless args
152 (signal 'error (list "Keyword is missing an argument" keyword))) 167 (signal 'error (list "Keyword is missing an argument" keyword)))
153 (setq args (cdr args)) 168 (setq args (cdr args))
154 (cond ((eq keyword :initialize) 169 (cond ((eq keyword :initialize)
155 (setq initialize value)) 170 (setq initialize value))
156 ((eq keyword :set) 171 ((eq keyword :set)
157 (put symbol 'custom-set value)) 172 (put symbol 'custom-set value))
158 ((eq keyword :get) 173 ((eq keyword :get)
159 (put symbol 'custom-get value)) 174 (put symbol 'custom-get value))
160 ((eq keyword :require) 175 ((eq keyword :require)
161 (setq requests (cons value requests))) 176 (push value requests))
162 ((eq keyword :type) 177 ((eq keyword :type)
163 (put symbol 'custom-type value)) 178 (put symbol 'custom-type (purecopy value)))
164 ((eq keyword :options) 179 ((eq keyword :options)
165 (if (get symbol 'custom-options) 180 (if (get symbol 'custom-options)
166 ;; Slow safe code to avoid duplicates. 181 ;; Slow safe code to avoid duplicates.
167 (mapc (lambda (option) 182 (mapc (lambda (option)
168 (custom-add-option symbol option)) 183 (custom-add-option symbol option))
169 value) 184 value)
170 ;; Fast code for the common case. 185 ;; Fast code for the common case.
171 (put symbol 'custom-options (copy-sequence value)))) 186 (put symbol 'custom-options (copy-sequence value))))
172 (t 187 (t
173 (custom-handle-keyword symbol keyword value 188 (custom-handle-keyword symbol keyword value
174 'custom-variable)))))) 189 'custom-variable))))))
175 (put symbol 'custom-requests requests) 190 (put symbol 'custom-requests requests)
176 ;; Do the actual initialization. 191 ;; Do the actual initialization.
177 (funcall initialize symbol default)) 192 (unless custom-dont-initialize
193 (funcall initialize symbol default)))
178 ;; #### This is a rough equivalent of LOADHIST_ATTACH. However, 194 ;; #### This is a rough equivalent of LOADHIST_ATTACH. However,
179 ;; LOADHIST_ATTACH also checks for `initialized'. 195 ;; LOADHIST_ATTACH also checks for `initialized'.
180 (push symbol current-load-list) 196 (push (cons 'defvar symbol) current-load-list)
181 (run-hooks 'custom-define-hook) 197 (run-hooks 'custom-define-hook)
182 symbol) 198 symbol)
183 199
184 (defmacro defcustom (symbol value doc &rest args) 200 (defmacro defcustom (symbol value doc &rest args)
185 "Declare SYMBOL as a customizable variable that defaults to VALUE. 201 "Declare SYMBOL as a customizable variable that defaults to VALUE.
191 207
192 [KEYWORD VALUE]... 208 [KEYWORD VALUE]...
193 209
194 The following keywords are meaningful: 210 The following keywords are meaningful:
195 211
196 :type VALUE should be a widget type for editing the symbols value. 212 :type VALUE should be a widget type for editing the symbol's value.
197 The default is `sexp'. 213 The default is `sexp'.
198 :options VALUE should be a list of valid members of the widget type. 214 :options VALUE should be a list of valid members of the widget type.
199 :group VALUE should be a customization group. 215 :group VALUE should be a customization group.
200 Add SYMBOL to that group. 216 Add SYMBOL to that group.
217 :link LINK-DATA
218 Include an external link after the documentation string for this
219 item. This is a sentence containing an active field which
220 references some other documentation.
221
222 There are three alternatives you can use for LINK-DATA:
223
224 (custom-manual INFO-NODE)
225 Link to an Info node; INFO-NODE is a string which specifies
226 the node name, as in \"(emacs)Top\". The link appears as
227 `[manual]' in the customization buffer.
228
229 (info-link INFO-NODE)
230 Like `custom-manual' except that the link appears in the
231 customization buffer with the Info node name.
232
233 (url-link URL)
234 Link to a web page; URL is a string which specifies the URL.
235 The link appears in the customization buffer as URL.
236
237 You can specify the text to use in the customization buffer by
238 adding `:tag NAME' after the first element of the LINK-DATA; for
239 example, (info-link :tag \"foo\" \"(emacs)Top\") makes a link to the
240 Emacs manual which appears in the buffer as `foo'.
241
242 An item can have more than one external link; however, most items
243 have none at all.
201 :initialize 244 :initialize
202 VALUE should be a function used to initialize the 245 VALUE should be a function used to initialize the
203 variable. It takes two arguments, the symbol and value 246 variable. It takes two arguments, the symbol and value
204 given in the `defcustom' call. The default is 247 given in the `defcustom' call. The default is
205 `custom-initialize-reset' 248 `custom-initialize-reset'.
206 :set VALUE should be a function to set the value of the symbol. 249 :set VALUE should be a function to set the value of the symbol.
207 It takes two arguments, the symbol to set and the value to 250 It takes two arguments, the symbol to set and the value to
208 give it. The default choice of function is `custom-set-default'. 251 give it. The default choice of function is `custom-set-default'.
209 :get VALUE should be a function to extract the value of symbol. 252 :get VALUE should be a function to extract the value of symbol.
210 The function takes one argument, a symbol, and should return 253 The function takes one argument, a symbol, and should return
217 it does (require VALUE) first. 260 it does (require VALUE) first.
218 :version 261 :version
219 VALUE should be a string specifying that the variable was 262 VALUE should be a string specifying that the variable was
220 first introduced, or its default value was changed, in Emacs 263 first introduced, or its default value was changed, in Emacs
221 version VERSION. 264 version VERSION.
222 :set-after VARIABLE 265 :tag LABEL
223 Specifies that SYMBOL should be set after VARIABLE when 266 Use LABEL, a string, instead of the item's name, to label the item
224 both have been customized. 267 in customization menus and buffers.
268 :load FILE
269 Load file FILE (a string) before displaying this customization
270 item. Loading is done with `load', and only if the file is
271 not already loaded.
272 :set-after VARIABLES
273 Specifies that SYMBOL should be set after the list of variables
274 VARIABLES when both have been customized.
225 275
226 Read the section about customization in the Emacs Lisp manual for more 276 Read the section about customization in the Emacs Lisp manual for more
227 information." 277 information."
228 `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)) 278 `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))
229
230 ;; END SYNC WITH FSF 21.2
231 279
232 ;;; The `defface' Macro. 280 ;;; The `defface' Macro.
233 281
234 (defmacro defface (face spec doc &rest args) 282 (defmacro defface (face spec doc &rest args)
235 "Declare FACE as a customizable face that defaults to SPEC. 283 "Declare FACE as a customizable face that defaults to SPEC.
275 Read the section about customization in the Emacs Lisp manual for more 323 Read the section about customization in the Emacs Lisp manual for more
276 information." 324 information."
277 `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) 325 `(custom-declare-face (quote ,face) ,spec ,doc ,@args))
278 326
279 ;;; The `defgroup' Macro. 327 ;;; The `defgroup' Macro.
328
329 (defun custom-current-group ()
330 (cdr (assoc load-file-name custom-current-group-alist)))
280 331
281 (defun custom-declare-group (symbol members doc &rest args) 332 (defun custom-declare-group (symbol members doc &rest args)
282 "Like `defgroup', but SYMBOL is evaluated as a normal argument." 333 "Like `defgroup', but SYMBOL is evaluated as a normal argument."
283 (while members 334 (while members
284 (apply 'custom-add-to-group symbol (car members)) 335 (apply 'custom-add-to-group symbol (car members))
285 (pop members)) 336 (pop members))
286 (put symbol 'custom-group (nconc members (get symbol 'custom-group)))
287 (when doc 337 (when doc
288 (put symbol 'group-documentation doc)) 338 (put symbol 'group-documentation doc))
289 (while args 339 (while args
290 (let ((arg (car args))) 340 (let ((arg (car args)))
291 (setq args (cdr args)) 341 (setq args (cdr args))
292 (check-argument-type 'keywordp arg) 342 (check-argument-type 'keywordp arg)
293 (let ((keyword arg) 343 (let ((keyword arg)
294 (value (car args))) 344 (value (car args)))
295 (unless args 345 (unless args
296 (signal 'error (list "Keyword is missing an argument" keyword))) 346 (signal 'error (list "Keyword is missing an argument" keyword)))
297 (setq args (cdr args)) 347 (setq args (cdr args))
298 (cond ((eq keyword :prefix) 348 (cond ((eq keyword :prefix)
299 (put symbol 'custom-prefix value)) 349 (put symbol 'custom-prefix value))
300 (t 350 (t
301 (custom-handle-keyword symbol keyword value 351 (custom-handle-keyword symbol keyword value
302 'custom-group)))))) 352 'custom-group))))))
353 ;; Record the group on the `current' list.
354 (let ((elt (assoc load-file-name custom-current-group-alist)))
355 (if elt (setcdr elt symbol)
356 (push (cons load-file-name symbol) custom-current-group-alist)))
303 (run-hooks 'custom-define-hook) 357 (run-hooks 'custom-define-hook)
304 symbol) 358 symbol)
305 359
306 (defmacro defgroup (symbol members doc &rest args) 360 (defmacro defgroup (symbol members doc &rest args)
307 "Declare SYMBOL as a customization group containing MEMBERS. 361 "Declare SYMBOL as a customization group containing MEMBERS.
316 370
317 The remaining arguments should have the form 371 The remaining arguments should have the form
318 372
319 [KEYWORD VALUE]... 373 [KEYWORD VALUE]...
320 374
321 The following KEYWORD's are defined: 375 The following KEYWORDs are defined:
322 376
323 :group VALUE should be a customization group. 377 :group VALUE should be a customization group.
324 Add SYMBOL to that group. 378 Add SYMBOL to that group.
325 379
326 Read the section about customization in the Emacs Lisp manual for more 380 Read the section about customization in the Emacs Lisp manual for more
327 information." 381 information."
382
383 ;; XEmacs: Evidently a purposeful omission from the docs:
384 ;:version VALUE should be a string specifying that the group was introduced
385 ; in Emacs version VERSION.
386 ;
387
388 ;; FSF: (not a problem for XEmacs)
389 ;; It is better not to use backquote in this file,
390 ;; because that makes a bootstrapping problem
391 ;; if you need to recompile all the Lisp files using interpreted code.
392 ; (nconc (list 'custom-declare-group (list 'quote symbol) members doc) args))
328 `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) 393 `(custom-declare-group (quote ,symbol) ,members ,doc ,@args))
329 394
330 (defvar custom-group-hash-table (make-hash-table :size 300 :test 'eq) 395 (defvar custom-group-hash-table (make-hash-table :size 300 :test 'eq)
331 "Hash-table of non-empty groups.") 396 "Hash-table of non-empty groups.")
332 397
333 (defun custom-add-to-group (group option widget) 398 (defun custom-add-to-group (group option widget)
334 "To existing GROUP add a new OPTION of type WIDGET. 399 "To existing GROUP add a new OPTION of type WIDGET.
335 If there already is an entry for that option, overwrite it." 400 If there already is an entry for OPTION and WIDGET, nothing is done."
336 (let* ((members (get group 'custom-group)) 401 (let ((members (get group 'custom-group))
337 (old (assq option members))) 402 (entry (list option widget)))
338 (if old 403 (unless (member entry members)
339 (setcar (cdr old) widget) 404 (put group 'custom-group (nconc members (list entry)))))
340 (put group 'custom-group (nconc members (list (list option widget))))))
341 (puthash group t custom-group-hash-table)) 405 (puthash group t custom-group-hash-table))
406
407 (defun custom-group-of-mode (mode)
408 "Return the custom group corresponding to the major or minor MODE.
409 If no such group is found, return nil."
410 (or (get mode 'custom-mode-group)
411 (if (or (get mode 'custom-group)
412 (and (string-match "-mode\\'" (symbol-name mode))
413 (get (setq mode (intern (substring (symbol-name mode)
414 0 (match-beginning 0))))
415 'custom-group)))
416 mode)))
342 417
343 ;;; Properties. 418 ;;; Properties.
344 419
345 (defun custom-handle-all-keywords (symbol args type) 420 (defun custom-handle-all-keywords (symbol args type)
346 "For customization option SYMBOL, handle keyword arguments ARGS. 421 "For customization option SYMBOL, handle keyword arguments ARGS.
347 Third argument TYPE is the custom option type." 422 Third argument TYPE is the custom option type."
423 (unless (memq :group args)
424 (custom-add-to-group (custom-current-group) symbol type))
348 (while args 425 (while args
349 (let ((arg (car args))) 426 (let ((arg (car args)))
350 (setq args (cdr args)) 427 (setq args (cdr args))
351 (check-argument-type 'keywordp arg) 428 (check-argument-type 'keywordp arg)
352 (let ((keyword arg) 429 (let ((keyword arg)
418 (puthash symbol t custom-group-hash-table) 495 (puthash symbol t custom-group-hash-table)
419 (let ((loads (get symbol 'custom-loads))) 496 (let ((loads (get symbol 'custom-loads)))
420 (unless (member load loads) 497 (unless (member load loads)
421 (put symbol 'custom-loads (cons load loads))))) 498 (put symbol 'custom-loads (cons load loads)))))
422 499
423 ;;; deftheme macro 500 (defun custom-autoload (symbol load)
501 "Mark SYMBOL as autoloaded custom variable and add dependency LOAD."
502 (put symbol 'custom-autoload t)
503 (custom-add-load symbol load))
504
505 ;; This test is also in the C code of `user-variable-p'.
506 (defun custom-variable-p (variable)
507 "Return non-nil if VARIABLE is a custom variable."
508 (or (get variable 'standard-value)
509 (get variable 'custom-autoload)))
510
511 ;;; Loading files needed to customize a symbol.
512 ;;; This is in custom.el because menu-bar.el needs it for toggle cmds.
513
514 (defvar custom-load-recursion nil
515 "Hack to avoid recursive dependencies.")
516
517 (defun custom-load-symbol (symbol)
518 "Load all dependencies for SYMBOL."
519 (unless custom-load-recursion
520 (let ((custom-load-recursion t))
521 (dolist (load (get symbol 'custom-loads))
522 (cond ((symbolp load) (condition-case nil (require load) (error nil)))
523 ;; This is subsumed by the test below, but it's much faster.
524 ((assoc load load-history))
525 ;; This was just (assoc (locate-library load) load-history)
526 ;; but has been optimized not to load locate-library
527 ;; if not necessary.
528 ((let ((regexp (concat "\\(\\`\\|/\\)" (regexp-quote load)
529 "\\(\\'\\|\\.\\)"))
530 (found nil))
531 (dolist (loaded load-history)
532 (and (stringp (car loaded))
533 (string-match regexp (car loaded))
534 (setq found t)))
535 found))
536 ;; Without this, we would load cus-edit recursively.
537 ;; We are still loading it when we call this,
538 ;; and it is not in load-history yet.
539 ((equal load "cus-edit"))
540 (t (condition-case nil (load load) (error nil))))))))
424 541
425 (defvar custom-known-themes '(user standard) 542 (defvar custom-known-themes '(user standard)
426 "Themes that have been defthemed.") 543 "Themes that have been define with `deftheme'.
427 544 The default value is the list (user standard). The theme `standard'
428 ;; #### add strings for group 545 contains the Emacs standard settings from the original Lisp files. The
429 ;; #### during bootstrap we cannot use cl-macs stuff 546 theme `user' contains all the the settings the user customized and saved.
430 (defun* custom-define-theme (theme feature &optional doc 547 Additional themes declared with the `deftheme' macro will be added to
431 &key short-description immediate variable-reset-string 548 the front of this list.")
432 variable-set-string face-set-string face-reset-string 549
433 &allow-other-keys) 550 (defun custom-declare-theme (theme feature &optional doc &rest args)
434 (push theme custom-known-themes) 551 "Like `deftheme', but THEME is evaluated as a normal argument.
552 FEATURE is the feature this theme provides. This symbol is created
553 from THEME by `custom-make-theme-feature'."
554 (add-to-list 'custom-known-themes theme)
435 (put theme 'theme-feature feature) 555 (put theme 'theme-feature feature)
436 (put theme 'theme-documentation doc) 556 (when doc
437 (if immediate (put theme 'theme-immediate immediate)) 557 (put theme 'theme-documentation doc))
438 (if variable-reset-string 558 (while args
439 (put theme 'theme-variable-reset-string variable-reset-string )) 559 (let ((arg (car args)))
440 (if variable-set-string 560 (setq args (cdr args))
441 (put theme 'theme-variable-set-string variable-set-string )) 561 (check-argument-type 'keywordp arg)
442 (if face-reset-string 562 (let ((keyword arg)
443 (put theme 'theme-face-reset-string face-reset-string )) 563 (value (car args)))
444 (if face-set-string 564 (unless args
445 (put theme 'theme-face-set-string face-set-string )) 565 (signal 'error (list "Keyword is missing an argument" keyword)))
446 (if short-description 566 (setq args (cdr args))
447 (put theme 'theme-short-description short-description ))) 567 (cond ((eq keyword :short-description)
568 (put theme 'theme-short-description value))
569 ((eq keyword :immediate)
570 (put theme 'theme-immediate value))
571 ((eq keyword :variable-set-string)
572 (put theme 'theme-variable-set-string value))
573 ((eq keyword :variable-reset-string)
574 (put theme 'theme-variable-reset-string value))
575 ((eq keyword :face-set-string)
576 (put theme 'theme-face-set-string value))
577 ((eq keyword :face-reset-string)
578 (put theme 'theme-face-reset-string value)))))))
579
580 (defmacro deftheme (theme &optional doc &rest args)
581 "Declare custom theme THEME.
582 The optional argument DOC is a doc string describing the theme.
583 The remaining arguments should have the form
584
585 [KEYWORD VALUE]...
586
587 The following KEYWORD's are defined:
588
589 :short-description
590 VALUE is a short (one line) description of the theme. If not
591 given, DOC is used.
592 :immediate
593 If VALUE is non-nil, variables specified in this theme are set
594 immediately when loading the theme.
595 :variable-set-string
596 VALUE is a string used to indicate that a variable takes its
597 setting from this theme. It is passed to FORMAT with the name
598 of the theme as an additional argument. If not given, a
599 generic description is used.
600 :variable-reset-string
601 VALUE is a string used in the case a variable has been forced
602 to its value in this theme. It is passed to FORMAT with the
603 name of the theme as an additional argument. If not given, a
604 generic description is used.
605 :face-set-string
606 VALUE is a string used to indicate that a face takes its
607 setting from this theme. It is passed to FORMAT with the name
608 of the theme as an additional argument. If not given, a
609 generic description is used.
610 :face-reset-string
611 VALUE is a string used in the case a face has been forced to
612 its value in this theme. It is passed to FORMAT with the name
613 of the theme as an additional argument. If not given, a
614 generic description is used.
615
616 Any theme `foo' should be defined in a file called `foo-theme.el';
617 see `custom-make-theme-feature' for more information."
618 (let ((feature (custom-make-theme-feature theme)))
619 ;; It is better not to use backquote in this file,
620 ;; because that makes a bootstrapping problem
621 ;; if you need to recompile all the Lisp files using interpreted code.
622 (nconc (list 'custom-declare-theme
623 (list 'quote theme)
624 (list 'quote feature)
625 doc) args)))
448 626
449 (defun custom-make-theme-feature (theme) 627 (defun custom-make-theme-feature (theme)
628 "Given a symbol THEME, create a new symbol by appending \"-theme\".
629 Store this symbol in the `theme-feature' property of THEME.
630 Calling `provide-theme' to provide THEME actually puts `THEME-theme'
631 into `features'.
632
633 This allows for a file-name convention for autoloading themes:
634 Every theme X has a property `provide-theme' whose value is \"X-theme\".
635 \(require-theme X) then attempts to load the file `X-theme.el'."
450 (intern (concat (symbol-name theme) "-theme"))) 636 (intern (concat (symbol-name theme) "-theme")))
451
452 (defmacro deftheme (theme &rest body)
453 "(deftheme THEME &optional DOC &key KEYWORDS)
454
455 Define a theme labeled by SYMBOL THEME. The optional argument DOC is a
456 doc string describing the theme. It is optionally followed by the
457 following keyword arguments
458
459 :short-description DESC
460 DESC is a short (one line) description of the theme. If not given DOC
461 is used.
462 :immediate FLAG
463 If FLAG is non-nil variables set in this theme are bound
464 immediately when loading the theme.
465 :variable-set-string VARIABLE_-SET-STRING
466 A string used by the UI to indicate that the value takes it
467 setting from this theme. It is passed to FORMAT with the
468 name of the theme a additional argument.
469 If not given, a generic description is used.
470 :variable-reset-string VARIABLE-RESET-STRING
471 As above but used in the case the variable has been forced to
472 the value in this theme.
473 :face-set-string FACE-SET-STRING
474 :face-reset-string FACE-RESET-STRING
475 As above but for faces."
476 (let ((feature (custom-make-theme-feature theme)))
477 `(custom-define-theme (quote ,theme) (quote ,feature) ,@body)))
478 637
479 (defsubst custom-theme-p (theme) 638 (defsubst custom-theme-p (theme)
480 "Non-nil when THEME has been defined." 639 "Non-nil when THEME has been defined."
481 (memq theme custom-known-themes)) 640 (memq theme custom-known-themes))
482 641
483 (defsubst custom-check-theme (theme) 642 (defsubst custom-check-theme (theme)
484 "Check whether THEME is valid and signal an error if NOT." 643 "Check whether THEME is valid, and signal an error if it is not."
485 (unless (custom-theme-p theme) 644 (unless (custom-theme-p theme)
486 (error "Unknown theme `%s'" theme))) 645 (error "Unknown theme `%s'" theme)))
487 646
488
489 ; #### do we need to deftheme 'user and/or 'standard here to make the
490 ; code in cus-edit cleaner?.
491
492 ;;; Initializing. 647 ;;; Initializing.
493 648
494 (defun custom-push-theme (prop symbol theme mode value) 649 (defun custom-push-theme (prop symbol theme mode value)
650 "Add (THEME MODE VALUE) to the list in property PROP of SYMBOL.
651 If the first element in that list is already (THEME ...),
652 discard it first.
653
654 MODE can be either the symbol `set' or the symbol `reset'. If it is the
655 symbol `set', then VALUE is the value to use. If it is the symbol
656 `reset', then VALUE is the mode to query instead.
657
658 In the following example for the variable `goto-address-url-face', the
659 theme `subtle-hacker' uses the same value for the variable as the theme
660 `gnome2':
661
662 \((standard set bold)
663 \(gnome2 set info-xref)
664 \(jonadab set underline)
665 \(subtle-hacker reset gnome2))
666
667
668 If a value has been stored for themes A B and C, and a new value
669 is to be stored for theme C, then the old value of C is discarded.
670 If a new value is to be stored for theme B, however, the old value
671 of B is not discarded because B is not the car of the list.
672
673 For variables, list property PROP is `theme-value'.
674 For faces, list property PROP is `theme-face'.
675 This is used in `custom-do-theme-reset', for example.
676
677 The list looks the same in any case; the examples shows a possible
678 value of the `theme-face' property for the face `region':
679
680 \((gnome2 set ((t (:foreground \"cyan\" :background \"dark cyan\"))))
681 \(standard set ((((class color) (background dark))
682 \(:background \"blue\"))
683 \(t (:background \"gray\")))))
684
685 This records values for the `standard' and the `gnome2' themes.
686 The user has not customized the face; had he done that,
687 the list would contain an entry for the `user' theme, too.
688 See `custom-known-themes' for a list of known themes."
495 (let ((old (get symbol prop))) 689 (let ((old (get symbol prop)))
496 (if (eq (car-safe (car-safe old)) theme) 690 (if (eq (car-safe (car-safe old)) theme)
497 (setq old (cdr old))) 691 (setq old (cdr old)))
498 (put symbol prop (cons (list theme mode value) old)))) 692 (put symbol prop (cons (list theme mode value) old))))
499 693
506 (put 'custom-local-buffer 'permanent-local t) 700 (put 'custom-local-buffer 'permanent-local t)
507 701
508 (defun custom-set-variables (&rest args) 702 (defun custom-set-variables (&rest args)
509 "Initialize variables according to user preferences. 703 "Initialize variables according to user preferences.
510 The settings are registered as theme `user'. 704 The settings are registered as theme `user'.
511 Each argument should be a list of the form: 705 The arguments should each be a list of the form:
706
707 (SYMBOL VALUE [NOW [REQUEST [COMMENT]]])
708
709 The unevaluated VALUE is stored as the saved value for SYMBOL.
710 If NOW is present and non-nil, VALUE is also evaluated and bound as
711 the default value for the SYMBOL.
712
713 REQUEST is a list of features we must 'require for SYMBOL.
714 COMMENT is a comment string about SYMBOL."
715 (apply 'custom-theme-set-variables 'user args))
716
717 (defun custom-theme-set-variables (theme &rest args)
718 "Initialize variables according to settings specified by args.
719 Records the settings as belonging to THEME.
720
721 The arguments should be a list where each entry has the form:
512 722
513 (SYMBOL VALUE [NOW [REQUEST [COMMENT]]]) 723 (SYMBOL VALUE [NOW [REQUEST [COMMENT]]])
514 724
515 The unevaluated VALUE is stored as the saved value for SYMBOL. 725 The unevaluated VALUE is stored as the saved value for SYMBOL.
516 If NOW is present and non-nil, VALUE is also evaluated and bound as 726 If NOW is present and non-nil, VALUE is also evaluated and bound as
517 the default value for the SYMBOL. 727 the default value for the SYMBOL.
518 REQUEST is a list of features we must 'require for SYMBOL. 728 REQUEST is a list of features we must 'require for SYMBOL.
519 COMMENT is a comment string about SYMBOL." 729 COMMENT is a comment string about SYMBOL.
520 (apply 'custom-theme-set-variables 'user args)) 730
521 731 Several properties of THEME and SYMBOL are used in the process:
522 (defun custom-theme-set-variables (theme &rest args) 732
523 "Initialize variables according to settings specified by args. 733 If THEME property `theme-immediate' is non-nil, this is equivalent of
524 Records the settings as belonging to THEME. 734 providing the NOW argument to all symbols in the argument list: SYMBOL
525 735 is bound to the evaluated VALUE. The only difference is SYMBOL property
526 See `custom-set-variables' for a description of the arguments ARGS." 736 `force-value': if NOW is non-nil, SYMBOL's property `force-value' is set to
737 the symbol `rogue', else if THEME's property `theme-immediate' is non-nil,
738 FACE's property `force-face' is set to the symbol `immediate'.
739
740 VALUE itself is saved unevaluated as SYMBOL property `saved-value' and
741 in SYMBOL's list property `theme-value' \(using `custom-push-theme')."
527 (custom-check-theme theme) 742 (custom-check-theme theme)
528 (setq args
529 (sort args
530 (lambda (a1 a2)
531 (let* ((sym1 (car a1))
532 (sym2 (car a2))
533 (1-then-2 (memq sym1 (get sym2 'custom-dependencies)))
534 (2-then-1 (memq sym2 (get sym1 'custom-dependencies))))
535 (cond ((and 1-then-2 2-then-1)
536 (error "Circular custom dependency between `%s' and `%s'"
537 sym1 sym2))
538 (1-then-2 t)
539 (2-then-1 nil)
540 ;; Put symbols with :require last. The macro
541 ;; define-minor-mode generates a defcustom
542 ;; with a :require and a :set, where the
543 ;; setter function calls the mode function.
544 ;; Putting symbols with :require last ensures
545 ;; that the mode function will see other
546 ;; customized values rather than default
547 ;; values.
548 (t (nth 3 a2)))))))
549 (let ((immediate (get theme 'theme-immediate))) 743 (let ((immediate (get theme 'theme-immediate)))
744 (setq args
745 (sort args
746 (lambda (a1 a2)
747 (let* ((sym1 (car a1))
748 (sym2 (car a2))
749 (1-then-2 (memq sym1 (get sym2 'custom-dependencies)))
750 (2-then-1 (memq sym2 (get sym1 'custom-dependencies))))
751 (cond ((and 1-then-2 2-then-1)
752 (error "Circular custom dependency between `%s' and `%s'"
753 sym1 sym2))
754 (2-then-1 nil)
755 ;; Put symbols with :require last. The macro
756 ;; define-minor-mode generates a defcustom
757 ;; with a :require and a :set, where the
758 ;; setter function calls the mode function.
759 ;; Putting symbols with :require last ensures
760 ;; that the mode function will see other
761 ;; customized values rather than default
762 ;; values.
763 (t (nth 3 a2)))))))
550 (while args 764 (while args
551 (let ((entry (car args))) 765 (let ((entry (car args)))
552 (if (listp entry) 766 (if (listp entry)
553 (let* ((symbol (nth 0 entry)) 767 (let* ((symbol (nth 0 entry))
554 (value (nth 1 entry)) 768 (value (nth 1 entry))
555 (now (nth 2 entry)) 769 (now (nth 2 entry))
556 (requests (nth 3 entry)) 770 (requests (nth 3 entry))
557 (comment (nth 4 entry)) 771 (comment (nth 4 entry))
558 (set (or (get symbol 'custom-set) 'custom-set-default))) 772 set)
559 (put symbol 'saved-value (list value)) 773 (when requests
774 (put symbol 'custom-requests requests)
775 (mapc 'require requests))
776 (setq set (or (get symbol 'custom-set) 'custom-set-default))
777 (put symbol 'saved-value (list value))
778 (put symbol 'saved-variable-comment comment)
560 (custom-push-theme 'theme-value symbol theme 'set value) 779 (custom-push-theme 'theme-value symbol theme 'set value)
561 (put symbol 'saved-variable-comment comment) 780 ;; Allow for errors in the case where the setter has
562 ;; Allow for errors in the case where the setter has 781 ;; changed between versions, say, but let the user know.
563 ;; changed between versions, say, but let the user know. 782 (condition-case data
564 (condition-case data 783 (cond ((or now immediate)
565 (cond ((or now immediate) 784 ;; Rogue variable, set it now.
566 ;; Rogue variable, set it now. 785 (put symbol 'force-value (if now 'rogue 'immediate))
567 (put symbol 'force-value (if now 'rogue 'immediate)) 786 (funcall set symbol (eval value)))
568 (funcall set symbol (eval value))) 787 ((default-boundp symbol)
569 ((default-boundp symbol) 788 ;; Something already set this, overwrite it.
570 ;; Something already set this, overwrite it. 789 (funcall set symbol (eval value))))
571 (funcall set symbol (eval value)))) 790 (error
572 (error
573 (message "Error setting %s: %s" symbol data))) 791 (message "Error setting %s: %s" symbol data)))
574 (and (or now (default-boundp symbol)) 792 (setq args (cdr args))
575 (put symbol 'variable-comment comment)) 793 (and (or now (default-boundp symbol))
576 (when requests 794 (put symbol 'variable-comment comment)))
577 (put symbol 'custom-requests requests) 795 ;; Old format, a plist of SYMBOL VALUE pairs.
578 (mapc 'require requests)) 796 (message "Warning: old format `custom-set-variables'")
579 (setq args (cdr args))) 797 (ding)
580 ;; Old format, a plist of SYMBOL VALUE pairs. 798 (sit-for 2)
581 (message "Warning: old format `custom-set-variables'") 799 (let ((symbol (nth 0 args))
582 (ding) 800 (value (nth 1 args)))
583 (sit-for 2) 801 (put symbol 'saved-value (list value))
584 (let ((symbol (nth 0 args))
585 (value (nth 1 args)))
586 (put symbol 'saved-value (list value))
587 (custom-push-theme 'theme-value symbol theme 'set value)) 802 (custom-push-theme 'theme-value symbol theme 'set value))
588 (setq args (cdr (cdr args)))))))) 803 (setq args (cdr (cdr args))))))))
589
590 (defvar custom-loaded-themes nil
591 "Themes in the order they are loaded.")
592
593 (defun custom-theme-loaded-p (theme)
594 "Return non-nil when THEME has been loaded."
595 (memq theme custom-loaded-themes))
596
597 (defun provide-theme (theme)
598 "Indicate that this file provides THEME."
599 (custom-check-theme theme)
600 (provide (get theme 'theme-feature))
601 (push theme custom-loaded-themes))
602
603 (defun require-theme (theme &optional soft)
604 "Try to load a theme by requiring its feature."
605 ;; Note we do no check for validity of the theme here.
606 ;; This allows to pull in themes by a file-name convention
607 (require (get theme 'theme-feature (custom-make-theme-feature theme))))
608
609 (defun custom-do-theme-reset (theme)
610 ; #### untested! slow!
611 (let (spec-list)
612 (mapatoms (lambda (symbol)
613 (setq spec-list (get symbol 'theme-value))
614 (when spec-list
615 (setq spec-list (delete-if (lambda (elt)
616 (eq (car elt) theme))
617 spec-list))
618 (put symbol 'theme-value spec-list)
619 (custom-theme-reset-internal symbol 'user))
620 (setq spec-list (get symbol 'theme-face))
621 (when spec-list
622 (setq spec-list (delete-if (lambda (elt)
623 (eq (car elt) theme))
624 spec-list))
625 (put symbol 'theme-face spec-list)
626 (custom-theme-reset-internal-face symbol 'user))))))
627
628 (defun custom-theme-load-themes (by-theme &rest body)
629 "Load the themes specified by BODY and record them as required by
630 theme BY-THEME. BODY is a sequence of
631 - a SYMBOL
632 require the theme SYMBOL
633 - a list (reset THEME)
634 Undo all the settings made by THEME.
635 - a list (hidden THEME)
636 require the THEME but hide it from the user."
637 (custom-check-theme by-theme)
638 (dolist (theme body)
639 (cond ((and (consp theme) (eq (car theme) 'reset))
640 (custom-do-theme-reset (cadr theme)))
641 ((and (consp theme) (eq (car theme) 'hidden))
642 (require-theme (cadr theme))
643 (unless (custom-theme-loaded-p (cadr theme))
644 (put (cadr theme) 'theme-hidden t)))
645 (t
646 (require-theme theme)
647 (remprop theme 'theme-hidden)))
648 (push theme (get by-theme 'theme-loads-themes))))
649
650 (defun custom-load-themes (&rest body)
651 "Load themes for the USER theme as specified by BODY.
652
653 BODY is as with custom-theme-load-themes."
654 (apply #'custom-theme-load-themes 'user body))
655
656
657
658
659 (defsubst copy-upto-last (elt list)
660 "Copy all the elements of the list upto the last occurrence of elt."
661 ;; Is it faster to do more work in C than to do less in elisp?
662 (nreverse (cdr (member elt (reverse list)))))
663
664 (defun custom-theme-value (theme theme-spec-list)
665 "Determine the value for THEME defined by THEME-SPEC-LIST.
666 Returns (list value) if found. Nil otherwise."
667 ;; Note we do _NOT_ signal an error if the theme is unknown
668 ;; it might have gone away without the user knowing.
669 (let ((theme-or-lower (memq theme (cons 'user custom-loaded-themes)))
670 value)
671 (mapc #'(lambda (theme-spec)
672 (when (member (car theme-spec) theme-or-lower)
673 (setq value (cdr theme-spec))
674 ;; We need to continue because if theme =A and we found
675 ;; B then if the load order is B A C B
676 ;; we actually want the value in C.
677 (setq theme-or-lower (copy-upto-last (car theme-spec)
678 theme-or-lower))
679 ;; We could should circuit if this is now nil.
680 ))
681 theme-spec-list)
682 (if value
683 (if (eq (car value) 'set)
684 (list (cadr value))
685 ;; Yet another reset spec. car value = reset
686 (custom-theme-value (cadr value) theme-spec-list)))))
687
688
689 (defun custom-theme-variable-value (variable theme)
690 "Return (list value) value of VARIABLE in THEME if the THEME modifies the
691 VARIABLE. Nil otherwise."
692 (custom-theme-value theme (get variable 'theme-value)))
693
694 (defun custom-theme-reset-internal (symbol to-theme)
695 (let ((value (custom-theme-variable-value symbol to-theme))
696 was-in-theme)
697 (setq was-in-theme value)
698 (setq value (or value (get symbol 'standard-value)))
699 (when value
700 (put symbol 'saved-value was-in-theme)
701 (if (or (get 'force-value symbol) (default-boundp symbol))
702 (funcall (get symbol 'custom-set 'set-default) symbol
703 (eval (car value)))))
704 value))
705
706
707 (defun custom-theme-reset-variables (theme &rest args)
708 "Reset the value of the variables to values previously defined.
709 Associate this setting with THEME.
710
711 ARGS is a list of lists of the form
712
713 (variable to-theme)
714
715 This means reset variable to its value in to-theme."
716 (custom-check-theme theme)
717 (mapc #'(lambda (arg)
718 (apply #'custom-theme-reset-internal arg)
719 (custom-push-theme 'theme-value (car arg) theme 'reset (cadr arg)))
720 args))
721
722 (defun custom-reset-variables (&rest args)
723 "Reset the value of the variables to values previously defined.
724 Associate this setting with the `user' theme.
725
726 The ARGS are as in `custom-theme-reset-variables'."
727 (apply #'custom-theme-reset-variables 'user args))
728 804
729 (defun custom-set-default (variable value) 805 (defun custom-set-default (variable value)
730 "Default :set function for a customizable variable. 806 "Default :set function for a customizable variable.
731 Normally, this sets the default value of VARIABLE to VALUE, 807 Normally, this sets the default value of VARIABLE to VALUE,
732 but if `custom-local-buffer' is non-nil, 808 but if `custom-local-buffer' is non-nil,
734 (if custom-local-buffer 810 (if custom-local-buffer
735 (with-current-buffer custom-local-buffer 811 (with-current-buffer custom-local-buffer
736 (set variable value)) 812 (set variable value))
737 (set-default variable value))) 813 (set-default variable value)))
738 814
815 (defun custom-quote (sexp)
816 "Quote SEXP iff it is not self quoting."
817 (if (or (memq sexp '(t nil))
818 (keywordp sexp)
819 (and (listp sexp)
820 (memq (car sexp) '(lambda)))
821 (stringp sexp)
822 (numberp sexp)
823 (vectorp sexp)
824 ;;; (and (fboundp 'characterp)
825 ;;; (characterp sexp))
826 )
827 sexp
828 (list 'quote sexp)))
829
830 (defun customize-mark-to-save (symbol)
831 "Mark SYMBOL for later saving.
832
833 If the default value of SYMBOL is different from the standard value,
834 set the `saved-value' property to a list whose car evaluates to the
835 default value. Otherwise, set it to nil.
836
837 To actually save the value, call `custom-save-all'.
838
839 Return non-nil iff the `saved-value' property actually changed."
840 (let* ((get (or (get symbol 'custom-get) 'default-value))
841 (value (funcall get symbol))
842 (saved (get symbol 'saved-value))
843 (standard (get symbol 'standard-value))
844 (comment (get symbol 'customized-variable-comment)))
845 ;; Save default value iff different from standard value.
846 (if (or (null standard)
847 (not (equal value (condition-case nil
848 (eval (car standard))
849 (error nil)))))
850 (put symbol 'saved-value (list (custom-quote value)))
851 (put symbol 'saved-value nil))
852 ;; Clear customized information (set, but not saved).
853 (put symbol 'customized-value nil)
854 ;; Save any comment that might have been set.
855 (when comment
856 (put symbol 'saved-variable-comment comment))
857 (not (equal saved (get symbol 'saved-value)))))
858
859 (defun customize-mark-as-set (symbol)
860 "Mark current value of SYMBOL as being set from customize.
861
862 If the default value of SYMBOL is different from the saved value if any,
863 or else if it is different from the standard value, set the
864 `customized-value' property to a list whose car evaluates to the
865 default value. Otherwise, set it to nil.
866
867 Return non-nil iff the `customized-value' property actually changed."
868 (let* ((get (or (get symbol 'custom-get) 'default-value))
869 (value (funcall get symbol))
870 (customized (get symbol 'customized-value))
871 (old (or (get symbol 'saved-value) (get symbol 'standard-value))))
872 ;; Mark default value as set iff different from old value.
873 (if (or (null old)
874 (not (equal value (condition-case nil
875 (eval (car old))
876 (error nil)))))
877 (put symbol 'customized-value (list (custom-quote value)))
878 (put symbol 'customized-value nil))
879 ;; Changed?
880 (not (equal customized (get symbol 'customized-value)))))
881
882 ;;; Theme Manipulation
883
884 (defvar custom-loaded-themes nil
885 "Themes in the order they are loaded.")
886
887 (defun custom-theme-loaded-p (theme)
888 "Return non-nil when THEME has been loaded."
889 (memq theme custom-loaded-themes))
890
891 (defun provide-theme (theme)
892 "Indicate that this file provides THEME.
893 Add THEME to `custom-loaded-themes' and `provide' whatever
894 is stored in THEME's property `theme-feature'.
895
896 Usually the theme-feature property contains a symbol created
897 by `custom-make-theme-feature'."
898 (custom-check-theme theme)
899 (provide (get theme 'theme-feature))
900 (setq custom-loaded-themes (nconc (list theme) custom-loaded-themes)))
901
902 (defun require-theme (theme)
903 "Try to load a theme by requiring its feature.
904 THEME's feature is stored in THEME's `theme-feature' property.
905
906 Usually the `theme-feature' property contains a symbol created
907 by `custom-make-theme-feature'."
908 ;; Note we do no check for validity of the theme here.
909 ;; This allows to pull in themes by a file-name convention
910 (require (or (get theme 'theme-feature)
911 (custom-make-theme-feature theme))))
912
913 (defun custom-remove-theme (spec-alist theme)
914 "Delete all elements from SPEC-ALIST whose car is THEME."
915 (let ((elt (assoc theme spec-alist)))
916 (while elt
917 (setq spec-alist (delete elt spec-alist)
918 elt (assoc theme spec-alist))))
919 spec-alist)
920
921 (defun custom-do-theme-reset (theme)
922 "Undo all settings defined by THEME.
923
924 A variable remains unchanged if its property `theme-value' does not
925 contain a value for THEME. A face remains unchanged if its property
926 `theme-face' does not contain a value for THEME. In either case, all
927 settings for THEME are removed from the property and the variable or
928 face is set to the `user' theme.
929
930 See `custom-known-themes' for a list of known themes."
931 (let (spec-list)
932 (mapatoms (lambda (symbol)
933 ;; This works even if symbol is both a variable and a
934 ;; face.
935 (setq spec-list (get symbol 'theme-value))
936 (when spec-list
937 (put symbol 'theme-value (custom-remove-theme spec-list theme))
938 (custom-theme-reset-internal symbol 'user))
939 (setq spec-list (get symbol 'theme-face))
940 (when spec-list
941 (put symbol 'theme-face (custom-remove-theme spec-list theme))
942 (custom-theme-reset-internal-face symbol 'user))))))
943
944 (defun custom-theme-load-themes (by-theme &rest body)
945 "Load the themes specified by BODY.
946 Record them as required by theme BY-THEME. BODY is a sequence of either
947
948 THEME
949 BY-THEME requires THEME
950 \(reset THEME)
951 Undo all the settings made by THEME
952 \(hidden THEME)
953 Require THEME but hide it from the user
954
955 All the themes loaded for BY-THEME are recorded in BY-THEME's property
956 `theme-loads-themes'. Any theme loaded with the hidden predicate will
957 be given the property `theme-hidden' unless it has been loaded before.
958 Whether a theme has been loaded before is determined by the function
959 `custom-theme-loaded-p'."
960 (custom-check-theme by-theme)
961 (let ((theme)
962 (themes-loaded (get by-theme 'theme-loads-themes)))
963 (while theme
964 (setq theme (car body)
965 body (cdr body))
966 (cond ((and (consp theme) (eq (car theme) 'reset))
967 (custom-do-theme-reset (cadr theme)))
968 ((and (consp theme) (eq (car theme) 'hidden))
969 (require-theme (cadr theme))
970 (unless (custom-theme-loaded-p (cadr theme))
971 (put (cadr theme) 'theme-hidden t)))
972 (t
973 (require-theme theme)
974 (put theme 'theme-hidden nil)))
975 (setq themes-loaded (nconc (list theme) themes-loaded)))
976 (put by-theme 'theme-loads-themes themes-loaded)))
977
978 (defun custom-load-themes (&rest body)
979 "Load themes for the USER theme as specified by BODY.
980
981 See `custom-theme-load-themes' for more information on BODY."
982 (apply 'custom-theme-load-themes 'user body))
983
984 ; (defsubst copy-upto-last (elt list)
985 ; "Copy all the elements of the list upto the last occurrence of elt"
986 ; ;; Is it faster to do more work in C than to do less in elisp?
987 ; (nreverse (cdr (member elt (reverse list)))))
988
989 (defun custom-theme-value (theme theme-spec-list)
990 "Determine the value for THEME defined by THEME-SPEC-LIST.
991 Returns a list with the original value if found; nil otherwise.
992
993 THEME-SPEC-LIST is an alist with themes as its key. As new themes are
994 installed, these are added to the front of THEME-SPEC-LIST.
995 Each element has the form
996
997 \(THEME MODE VALUE)
998
999 MODE is either the symbol `set' or the symbol `reset'. See
1000 `custom-push-theme' for more information on the format of
1001 THEME-SPEC-LIST."
1002 ;; Note we do _NOT_ signal an error if the theme is unknown
1003 ;; it might have gone away without the user knowing.
1004 (let ((value (cdr (assoc theme theme-spec-list))))
1005 (if value
1006 (if (eq (car value) 'set)
1007 (cdr value)
1008 (custom-theme-value (cadr value) theme-spec-list)))))
1009
1010 (defun custom-theme-variable-value (variable theme)
1011 "Return (list value) indicating value of VARIABLE in THEME.
1012 If THEME does not define a value for VARIABLE, return nil. The value
1013 definitions per theme are stored in VARIABLE's property `theme-value'.
1014 The actual work is done by function `custom-theme-value', which see.
1015 See `custom-push-theme' for more information on how these definitions
1016 are stored."
1017 (custom-theme-value theme (get variable 'theme-value)))
1018
1019 (defun custom-theme-reset-internal (symbol to-theme)
1020 "Reset SYMBOL to the value defined by TO-THEME.
1021 If SYMBOL is not defined in TO-THEME, reset SYMBOL to the standard
1022 value. See `custom-theme-variable-value'. The standard value is
1023 stored in SYMBOL's property `standard-value'."
1024 (let ((value (custom-theme-variable-value symbol to-theme))
1025 was-in-theme)
1026 (setq was-in-theme value)
1027 (setq value (or value (get symbol 'standard-value)))
1028 (when value
1029 (put symbol 'saved-value was-in-theme)
1030 (if (or (get 'force-value symbol) (default-boundp symbol))
1031 (funcall (or (get symbol 'custom-set) 'set-default) symbol
1032 (eval (car value)))))
1033 value))
1034
1035 (defun custom-theme-reset-variables (theme &rest args)
1036 "Reset the value of the variables to values previously defined.
1037 Associate this setting with THEME.
1038
1039 ARGS is a list of lists of the form
1040
1041 (VARIABLE TO-THEME)
1042
1043 This means reset VARIABLE to its value in TO-THEME."
1044 (custom-check-theme theme)
1045 (mapcar '(lambda (arg)
1046 (apply 'custom-theme-reset-internal arg)
1047 (custom-push-theme 'theme-value (car arg) theme 'reset (cadr arg)))
1048 args))
1049
1050 (defun custom-reset-variables (&rest args)
1051 "Reset the value of the variables to values previously saved.
1052 This is the setting associated the `user' theme.
1053
1054 ARGS is a list of lists of the form
1055
1056 (VARIABLE TO-THEME)
1057
1058 This means reset VARIABLE to its value in TO-THEME."
1059 (apply 'custom-theme-reset-variables 'user args))
1060
739 ;;; The End. 1061 ;;; The End.
740
741 ;; BEGIN SYNC WITH FSF 21.2
742 1062
743 ;; Process the defcustoms for variables loaded before this file. 1063 ;; Process the defcustoms for variables loaded before this file.
744 ;; `custom-declare-variable-list' is defvar'd in subr.el. Utility programs 1064 ;; `custom-declare-variable-list' is defvar'd in subr.el. Utility programs
745 ;; run from temacs that do not load subr.el should defvar it themselves. 1065 ;; run from temacs that do not load subr.el should defvar it themselves.
746 ;; (As of 21.5.11, make-docfile.el.) 1066 ;; (As of 21.5.11, make-docfile.el.)
747 (while custom-declare-variable-list 1067 (while custom-declare-variable-list
748 (apply 'custom-declare-variable (car custom-declare-variable-list)) 1068 (apply 'custom-declare-variable (car custom-declare-variable-list))
749 (setq custom-declare-variable-list (cdr custom-declare-variable-list))) 1069 (setq custom-declare-variable-list (cdr custom-declare-variable-list)))
750 1070
751 ;; END SYNC WITH FSF 21.2
752
753 ;; custom.el ends here 1071 ;; custom.el ends here