Mercurial > hg > xemacs-beta

comparison lisp/custom/custom.el @ 136:b980b6286996 r20-2b2

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