Mercurial > hg > xemacs-beta

comparison lisp/custom/custom.el @ 134:34a5b81f86ba r20-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b1
author cvs
date Mon, 13 Aug 2007 09:30:11 +0200
parents 9b50b4588a93
children b980b6286996
comparison
equal deleted inserted replaced
133:b27e67717092 134:34a5b81f86ba
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 ;; Keywords: help, faces 6 ;; Keywords: help, faces
7 ;; Version: 1.84 7 ;; Version: 1.89
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
9 9
10 ;;; Commentary: 10 ;;; Commentary:
11 ;; 11 ;;
12 ;; If you want to use this code, please visit the URL above. 12 ;; If you want to use this code, please visit the URL above.
19 19
20 ;;; Code: 20 ;;; Code:
21 21
22 (require 'widget) 22 (require 'widget)
23 23
24 (define-widget-keywords :prefix :tag :load :link :options :type :group) 24 (define-widget-keywords :initialize :set :get :require :prefix :tag
25 :load :link :options :type :group)
25 26
26 ;; These autoloads should be deleted eventually. 27 ;; These autoloads should be deleted eventually.
27 (unless (fboundp 'load-gc) 28 (unless (fboundp 'load-gc)
28 ;; From cus-edit.el 29 ;; From cus-edit.el
29 (autoload 'customize "cus-edit" nil t) 30 (autoload 'customize "cus-edit" nil t)
31 (autoload 'customize-other-window "cus-edit" nil t)
30 (autoload 'customize-variable "cus-edit" nil t) 32 (autoload 'customize-variable "cus-edit" nil t)
31 (autoload 'customize-variable-other-window "cus-edit" nil t) 33 (autoload 'customize-variable-other-window "cus-edit" nil t)
32 (autoload 'customize-face "cus-edit" nil t) 34 (autoload 'customize-face "cus-edit" nil t)
33 (autoload 'customize-face-other-window "cus-edit" nil t) 35 (autoload 'customize-face-other-window "cus-edit" nil t)
34 (autoload 'customize-apropos "cus-edit" nil t) 36 (autoload 'customize-apropos "cus-edit" nil t)
46 ;; Customize information for this option is in `cus-edit.el'. 48 ;; Customize information for this option is in `cus-edit.el'.
47 "Hook called after defining each customize option.") 49 "Hook called after defining each customize option.")
48 50
49 ;;; The `defcustom' Macro. 51 ;;; The `defcustom' Macro.
50 52
51 (defun custom-declare-variable (symbol value doc &rest args) 53 (defun custom-initialize-default (symbol value)
52 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." 54 "Initialize SYMBOL with VALUE.
53 ;; Bind this variable unless it already is bound. 55 This will do nothing if symbol already has a default binding.
56 Otherwise, if symbol has a `saved-value' property, it will evaluate
57 the car of that and used as the default binding for symbol.
58 Otherwise, VALUE will be evaluated and used as the default binding for
59 symbol."
54 (unless (default-boundp symbol) 60 (unless (default-boundp symbol)
55 ;; Use the saved value if it exists, otherwise the factory setting. 61 ;; Use the saved value if it exists, otherwise the factory setting.
56 (set-default symbol (if (get symbol 'saved-value) 62 (set-default symbol (if (get symbol 'saved-value)
57 (eval (car (get symbol 'saved-value))) 63 (eval (car (get symbol 'saved-value)))
58 (eval value)))) 64 (eval value)))))
65
66 (defun custom-initialize-set (symbol value)
67 "Initialize SYMBOL with VALUE.
68 Like `custom-initialize-default', but use the function specified by
69 `:set' to initialize SYMBOL."
70 (unless (default-boundp symbol)
71 (funcall (or (get symbol 'custom-set) 'set-default)
72 symbol
73 (if (get symbol 'saved-value)
74 (eval (car (get symbol 'saved-value)))
75 (eval value)))))
76
77 (defun custom-initialize-reset (symbol value)
78 "Initialize SYMBOL with VALUE.
79 Like `custom-initialize-set', but use the function specified by
80 `:get' to reinitialize SYMBOL if it is already bound."
81 (funcall (or (get symbol 'custom-set) 'set-default)
82 symbol
83 (cond ((default-boundp symbol)
84 (funcall (or (get symbol 'custom-get) 'default-value)
85 symbol))
86 ((get symbol 'saved-value)
87 (eval (car (get symbol 'saved-value))))
88 (t
89 (eval value)))))
90
91 (defun custom-initialize-changed (symbol value)
92 "Initialize SYMBOL with VALUE.
93 Like `custom-initialize-reset', but only use the `:set' function if the
94 not using the factory setting. Otherwise, use the `set-default'."
95 (cond ((default-boundp symbol)
96 (funcall (or (get symbol 'custom-set) 'set-default)
97 symbol
98 (funcall (or (get symbol 'custom-get) 'default-value)
99 symbol)))
100 ((get symbol 'saved-value)
101 (funcall (or (get symbol 'custom-set) 'set-default)
102 symbol
103 (eval (car (get symbol 'saved-value)))))
104 (t
105 (set-default symbol (eval value)))))
106
107 (defun custom-declare-variable (symbol value doc &rest args)
108 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
59 ;; Remember the factory setting. 109 ;; Remember the factory setting.
60 (put symbol 'factory-value (list value)) 110 (put symbol 'factory-value (list value))
61 ;; Maybe this option was rogue in an earlier version. It no longer is. 111 ;; Maybe this option was rogue in an earlier version. It no longer is.
62 (when (get symbol 'force-value) 112 (when (get symbol 'force-value)
63 ;; It no longer is. 113 ;; It no longer is.
64 (put symbol 'force-value nil)) 114 (put symbol 'force-value nil))
65 (when doc 115 (when doc
66 (put symbol 'variable-documentation doc)) 116 (put symbol 'variable-documentation doc))
67 (while args 117 (let ((initialize 'custom-initialize-set)
68 (let ((arg (car args))) 118 (requests nil))
69 (setq args (cdr args)) 119 (while args
70 (unless (symbolp arg) 120 (let ((arg (car args)))
71 (error "Junk in args %S" args))
72 (let ((keyword arg)
73 (value (car args)))
74 (unless args
75 (error "Keyword %s is missing an argument" keyword))
76 (setq args (cdr args)) 121 (setq args (cdr args))
77 (cond ((eq keyword :type) 122 (unless (symbolp arg)
78 (put symbol 'custom-type value)) 123 (error "Junk in args %S" args))
79 ((eq keyword :options) 124 (let ((keyword arg)
80 (if (get symbol 'custom-options) 125 (value (car args)))
81 ;; Slow safe code to avoid duplicates. 126 (unless args
82 (mapcar (lambda (option) 127 (error "Keyword %s is missing an argument" keyword))
83 (custom-add-option symbol option)) 128 (setq args (cdr args))
84 value) 129 (cond ((eq keyword :initialize)
85 ;; Fast code for the common case. 130 (setq initialize value))
86 (put symbol 'custom-options (copy-list value)))) 131 ((eq keyword :set)
87 (t 132 (put symbol 'custom-set value))
88 (custom-handle-keyword symbol keyword value 133 ((eq keyword :get)
89 'custom-variable)))))) 134 (put symbol 'custom-get value))
135 ((eq keyword :require)
136 (push value requests))
137 ((eq keyword :type)
138 (put symbol 'custom-type value))
139 ((eq keyword :options)
140 (if (get symbol 'custom-options)
141 ;; Slow safe code to avoid duplicates.
142 (mapcar (lambda (option)
143 (custom-add-option symbol option))
144 value)
145 ;; Fast code for the common case.
146 (put symbol 'custom-options (append value nil))))
147 (t
148 (custom-handle-keyword symbol keyword value
149 'custom-variable))))))
150 (put symbol 'custom-requests requests)
151 ;; Do the actual initialization.
152 (funcall initialize symbol value))
90 (run-hooks 'custom-define-hook) 153 (run-hooks 'custom-define-hook)
91 symbol) 154 symbol)
92 155
93 (defmacro defcustom (symbol value doc &rest args) 156 (defmacro defcustom (symbol value doc &rest args)
94 "Declare SYMBOL as a customizable variable that defaults to VALUE. 157 "Declare SYMBOL as a customizable variable that defaults to VALUE.
100 163
101 [KEYWORD VALUE]... 164 [KEYWORD VALUE]...
102 165
103 The following KEYWORD's are defined: 166 The following KEYWORD's are defined:
104 167
105 :type VALUE should be a widget type. 168 :type VALUE should be a widget type for editing the symbols value.
169 The default is `sexp'.
106 :options VALUE should be a list of valid members of the widget type. 170 :options VALUE should be a list of valid members of the widget type.
107 :group VALUE should be a customization group. 171 :group VALUE should be a customization group.
108 Add SYMBOL to that group. 172 Add SYMBOL to that group.
109 173 :initialize VALUE should be a function used to initialize the
110 Read the section about customization in the emacs lisp manual for more 174 variable. It takes two arguments, the symbol and value
175 given in the `defcustom' call. The default is
176 `custom-initialize-default'
177 :set VALUE should be a function to set the value of the symbol.
178 It takes two arguments, the symbol to set and the value to
179 give it. The default is `set-default'.
180 :get VALUE should be a function to extract the value of symbol.
181 The function takes one argument, a symbol, and should return
182 the current value for that symbol. The default is
183 `default-value'.
184 :require VALUE should be a feature symbol. Each feature will be
185 required after initialization, of the the user have saved this
186 option.
187
188 Read the section about customization in the Emacs Lisp manual for more
111 information." 189 information."
112 `(eval-and-compile 190 `(eval-and-compile
113 (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))) 191 (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)))
114 192
115 ;;; The `defface' Macro. 193 ;;; The `defface' Macro.
155 Should be one of `color', `grayscale', or `mono'. 233 Should be one of `color', `grayscale', or `mono'.
156 234
157 `background' (what color is used for the background text) 235 `background' (what color is used for the background text)
158 Should be one of `light' or `dark'. 236 Should be one of `light' or `dark'.
159 237
160 Read the section about customization in the emacs lisp manual for more 238 Read the section about customization in the Emacs Lisp manual for more
161 information." 239 information."
162 `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) 240 `(custom-declare-face (quote ,face) ,spec ,doc ,@args))
163 241
164 ;;; The `defgroup' Macro. 242 ;;; The `defgroup' Macro.
165 243
166 (defun custom-declare-group (symbol members doc &rest args) 244 (defun custom-declare-group (symbol members doc &rest args)
167 "Like `defgroup', but SYMBOL is evaluated as a normal argument." 245 "Like `defgroup', but SYMBOL is evaluated as a normal argument."
246 (while members
247 (apply 'custom-add-to-group symbol (car members))
248 (setq members (cdr members)))
168 (put symbol 'custom-group (nconc members (get symbol 'custom-group))) 249 (put symbol 'custom-group (nconc members (get symbol 'custom-group)))
169 (when doc 250 (when doc
170 (put symbol 'group-documentation doc)) 251 (put symbol 'group-documentation doc))
171 (while args 252 (while args
172 (let ((arg (car args))) 253 (let ((arg (car args)))
204 The following KEYWORD's are defined: 285 The following KEYWORD's are defined:
205 286
206 :group VALUE should be a customization group. 287 :group VALUE should be a customization group.
207 Add SYMBOL to that group. 288 Add SYMBOL to that group.
208 289
209 Read the section about customization in the emacs lisp manual for more 290 Read the section about customization in the Emacs Lisp manual for more
210 information." 291 information."
211 `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) 292 `(custom-declare-group (quote ,symbol) ,members ,doc ,@args))
212 293
213 (defun custom-add-to-group (group option widget) 294 (defun custom-add-to-group (group option widget)
214 "To existing GROUP add a new OPTION of type WIDGET. 295 "To existing GROUP add a new OPTION of type WIDGET.
285 If NOW is present and non-nil, VALUE is also evaluated and bound as 366 If NOW is present and non-nil, VALUE is also evaluated and bound as
286 the default value for the SYMBOL." 367 the default value for the SYMBOL."
287 (while args 368 (while args
288 (let ((entry (car args))) 369 (let ((entry (car args)))
289 (if (listp entry) 370 (if (listp entry)
290 (let ((symbol (nth 0 entry)) 371 (let* ((symbol (nth 0 entry))
291 (value (nth 1 entry)) 372 (value (nth 1 entry))
292 (now (nth 2 entry))) 373 (now (nth 2 entry))
374 (requests (nth 3 entry))
375 (set (or (get symbol 'custom-set) 'set-default)))
293 (put symbol 'saved-value (list value)) 376 (put symbol 'saved-value (list value))
294 (cond (now 377 (cond (now
295 ;; Rogue variable, set it now. 378 ;; Rogue variable, set it now.
296 (put symbol 'force-value t) 379 (put symbol 'force-value t)
297 (set-default symbol (eval value))) 380 (funcall set symbol (eval value)))
298 ((default-boundp symbol) 381 ((default-boundp symbol)
299 ;; Something already set this, overwrite it. 382 ;; Something already set this, overwrite it.
300 (set-default symbol (eval value)))) 383 (funcall set symbol (eval value))))
384 (when requests
385 (put symbol 'custom-requests requests)
386 (mapcar 'require requests))
301 (setq args (cdr args))) 387 (setq args (cdr args)))
302 ;; Old format, a plist of SYMBOL VALUE pairs. 388 ;; Old format, a plist of SYMBOL VALUE pairs.
303 (message "Warning: old format `custom-set-variables'") 389 (message "Warning: old format `custom-set-variables'")
304 (ding) 390 (ding)
305 (sit-for 2) 391 (sit-for 2)