Mercurial > hg > xemacs-beta

comparison lisp/custom/custom.el @ 149:538048ae2ab8 r20-3b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b1
author cvs
date Mon, 13 Aug 2007 09:36:16 +0200
parents b980b6286996
children 25f70ba0133c
comparison
equal deleted inserted replaced
148:f659db2a1f73 149:538048ae2ab8
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.97
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
9 26
10 ;;; Commentary: 27 ;;; Commentary:
11 ;; 28 ;;
12 ;; If you want to use this code, please visit the URL above. 29 ;; If you want to use this code, please visit the URL above.
13 ;; 30 ;;
19 36
20 ;;; Code: 37 ;;; Code:
21 38
22 (require 'widget) 39 (require 'widget)
23 40
24 (define-widget-keywords :prefix :tag :load :link :options :type :group) 41 (define-widget-keywords :initialize :set :get :require :prefix :tag
42 :load :link :options :type :group)
25 43
26 ;; These autoloads should be deleted eventually. 44 ;; These autoloads should be deleted eventually.
27 (unless (fboundp 'load-gc) 45 (unless (fboundp 'load-gc)
28 ;; From cus-edit.el 46 ;; From cus-edit.el
47 (autoload 'custom-set-value "cus-edit" nil t)
48 (autoload 'custom-set-variable "cus-edit" nil t)
29 (autoload 'customize "cus-edit" nil t) 49 (autoload 'customize "cus-edit" nil t)
50 (autoload 'customize-other-window "cus-edit" nil t)
30 (autoload 'customize-variable "cus-edit" nil t) 51 (autoload 'customize-variable "cus-edit" nil t)
31 (autoload 'customize-variable-other-window "cus-edit" nil t) 52 (autoload 'customize-variable-other-window "cus-edit" nil t)
32 (autoload 'customize-face "cus-edit" nil t) 53 (autoload 'customize-face "cus-edit" nil t)
33 (autoload 'customize-face-other-window "cus-edit" nil t) 54 (autoload 'customize-face-other-window "cus-edit" nil t)
34 (autoload 'customize-apropos "cus-edit" nil t) 55 (autoload 'customize-apropos "cus-edit" nil t)
35 (autoload 'customize-customized "cus-edit" nil t) 56 (autoload 'customize-customized "cus-edit" nil t)
57 (autoload 'customize-saved "cus-edit" nil t)
36 (autoload 'custom-buffer-create "cus-edit") 58 (autoload 'custom-buffer-create "cus-edit")
37 (autoload 'custom-make-dependencies "cus-edit") 59 (autoload 'custom-make-dependencies "cus-edit")
38 (autoload 'custom-menu-create "cus-edit") 60 (autoload 'custom-menu-create "cus-edit")
39 (autoload 'customize-menu-create "cus-edit") 61 (autoload 'customize-menu-create "cus-edit")
40 62
46 ;; Customize information for this option is in `cus-edit.el'. 68 ;; Customize information for this option is in `cus-edit.el'.
47 "Hook called after defining each customize option.") 69 "Hook called after defining each customize option.")
48 70
49 ;;; The `defcustom' Macro. 71 ;;; The `defcustom' Macro.
50 72
51 (defun custom-declare-variable (symbol value doc &rest args) 73 (defun custom-initialize-default (symbol value)
52 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." 74 "Initialize SYMBOL with VALUE.
53 ;; Bind this variable unless it already is bound. 75 This will do nothing if symbol already has a default binding.
76 Otherwise, if symbol has a `saved-value' property, it will evaluate
77 the car of that and used as the default binding for symbol.
78 Otherwise, VALUE will be evaluated and used as the default binding for
79 symbol."
54 (unless (default-boundp symbol) 80 (unless (default-boundp symbol)
55 ;; Use the saved value if it exists, otherwise the factory setting. 81 ;; Use the saved value if it exists, otherwise the factory setting.
56 (set-default symbol (if (get symbol 'saved-value) 82 (set-default symbol (if (get symbol 'saved-value)
57 (eval (car (get symbol 'saved-value))) 83 (eval (car (get symbol 'saved-value)))
58 (eval value)))) 84 (eval value)))))
85
86 (defun custom-initialize-set (symbol value)
87 "Initialize SYMBOL with VALUE.
88 Like `custom-initialize-default', but use the function specified by
89 `:set' to initialize SYMBOL."
90 (unless (default-boundp symbol)
91 (funcall (or (get symbol 'custom-set) 'set-default)
92 symbol
93 (if (get symbol 'saved-value)
94 (eval (car (get symbol 'saved-value)))
95 (eval value)))))
96
97 (defun custom-initialize-reset (symbol value)
98 "Initialize SYMBOL with VALUE.
99 Like `custom-initialize-set', but use the function specified by
100 `:get' to reinitialize SYMBOL if it is already bound."
101 (funcall (or (get symbol 'custom-set) 'set-default)
102 symbol
103 (cond ((default-boundp symbol)
104 (funcall (or (get symbol 'custom-get) 'default-value)
105 symbol))
106 ((get symbol 'saved-value)
107 (eval (car (get symbol 'saved-value))))
108 (t
109 (eval value)))))
110
111 (defun custom-initialize-changed (symbol value)
112 "Initialize SYMBOL with VALUE.
113 Like `custom-initialize-reset', but only use the `:set' function if the
114 not using the factory setting. Otherwise, use the `set-default'."
115 (cond ((default-boundp symbol)
116 (funcall (or (get symbol 'custom-set) 'set-default)
117 symbol
118 (funcall (or (get symbol 'custom-get) 'default-value)
119 symbol)))
120 ((get symbol 'saved-value)
121 (funcall (or (get symbol 'custom-set) 'set-default)
122 symbol
123 (eval (car (get symbol 'saved-value)))))
124 (t
125 (set-default symbol (eval value)))))
126
127 (defun custom-declare-variable (symbol value doc &rest args)
128 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
59 ;; Remember the factory setting. 129 ;; Remember the factory setting.
60 (put symbol 'factory-value (list value)) 130 (put symbol 'factory-value (list value))
61 ;; Maybe this option was rogue in an earlier version. It no longer is. 131 ;; Maybe this option was rogue in an earlier version. It no longer is.
62 (when (get symbol 'force-value) 132 (when (get symbol 'force-value)
63 ;; It no longer is. 133 ;; It no longer is.
64 (put symbol 'force-value nil)) 134 (put symbol 'force-value nil))
65 (when doc 135 (when doc
66 (put symbol 'variable-documentation doc)) 136 (put symbol 'variable-documentation doc))
67 (while args 137 (let ((initialize 'custom-initialize-set)
68 (let ((arg (car args))) 138 (requests nil))
69 (setq args (cdr args)) 139 (while args
70 (unless (symbolp arg) 140 (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)) 141 (setq args (cdr args))
77 (cond ((eq keyword :type) 142 (unless (symbolp arg)
78 (put symbol 'custom-type value)) 143 (error "Junk in args %S" args))
79 ((eq keyword :options) 144 (let ((keyword arg)
80 (if (get symbol 'custom-options) 145 (value (car args)))
81 ;; Slow safe code to avoid duplicates. 146 (unless args
82 (mapcar (lambda (option) 147 (error "Keyword %s is missing an argument" keyword))
83 (custom-add-option symbol option)) 148 (setq args (cdr args))
84 value) 149 (cond ((eq keyword :initialize)
85 ;; Fast code for the common case. 150 (setq initialize value))
86 (put symbol 'custom-options (copy-list value)))) 151 ((eq keyword :set)
87 (t 152 (put symbol 'custom-set value))
88 (custom-handle-keyword symbol keyword value 153 ((eq keyword :get)
89 'custom-variable)))))) 154 (put symbol 'custom-get value))
155 ((eq keyword :require)
156 (push value requests))
157 ((eq keyword :type)
158 (put symbol 'custom-type value))
159 ((eq keyword :options)
160 (if (get symbol 'custom-options)
161 ;; Slow safe code to avoid duplicates.
162 (mapcar (lambda (option)
163 (custom-add-option symbol option))
164 value)
165 ;; Fast code for the common case.
166 (put symbol 'custom-options (copy-sequence value))))
167 (t
168 (custom-handle-keyword symbol keyword value
169 'custom-variable))))))
170 (put symbol 'custom-requests requests)
171 ;; Do the actual initialization.
172 (funcall initialize symbol value))
90 (run-hooks 'custom-define-hook) 173 (run-hooks 'custom-define-hook)
91 symbol) 174 symbol)
92 175
93 (defmacro defcustom (symbol value doc &rest args) 176 (defmacro defcustom (symbol value doc &rest args)
94 "Declare SYMBOL as a customizable variable that defaults to VALUE. 177 "Declare SYMBOL as a customizable variable that defaults to VALUE.
100 183
101 [KEYWORD VALUE]... 184 [KEYWORD VALUE]...
102 185
103 The following KEYWORD's are defined: 186 The following KEYWORD's are defined:
104 187
105 :type VALUE should be a widget type. 188 :type VALUE should be a widget type for editing the symbols value.
189 The default is `sexp'.
106 :options VALUE should be a list of valid members of the widget type. 190 :options VALUE should be a list of valid members of the widget type.
107 :group VALUE should be a customization group. 191 :group VALUE should be a customization group.
108 Add SYMBOL to that group. 192 Add SYMBOL to that group.
109 193 :initialize VALUE should be a function used to initialize the
110 Read the section about customization in the emacs lisp manual for more 194 variable. It takes two arguments, the symbol and value
195 given in the `defcustom' call. The default is
196 `custom-initialize-default'
197 :set VALUE should be a function to set the value of the symbol.
198 It takes two arguments, the symbol to set and the value to
199 give it. The default is `set-default'.
200 :get VALUE should be a function to extract the value of symbol.
201 The function takes one argument, a symbol, and should return
202 the current value for that symbol. The default is
203 `default-value'.
204 :require VALUE should be a feature symbol. Each feature will be
205 required after initialization, of the the user have saved this
206 option.
207
208 Read the section about customization in the Emacs Lisp manual for more
111 information." 209 information."
112 `(eval-and-compile 210 `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))
113 (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)))
114 211
115 ;;; The `defface' Macro. 212 ;;; The `defface' Macro.
116 213
117 (defmacro defface (face spec doc &rest args) 214 (defmacro defface (face spec doc &rest args)
118 "Declare FACE as a customizable face that defaults to SPEC. 215 "Declare FACE as a customizable face that defaults to SPEC.
155 Should be one of `color', `grayscale', or `mono'. 252 Should be one of `color', `grayscale', or `mono'.
156 253
157 `background' (what color is used for the background text) 254 `background' (what color is used for the background text)
158 Should be one of `light' or `dark'. 255 Should be one of `light' or `dark'.
159 256
160 Read the section about customization in the emacs lisp manual for more 257 Read the section about customization in the Emacs Lisp manual for more
161 information." 258 information."
162 `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) 259 `(custom-declare-face (quote ,face) ,spec ,doc ,@args))
163 260
164 ;;; The `defgroup' Macro. 261 ;;; The `defgroup' Macro.
165 262
166 (defun custom-declare-group (symbol members doc &rest args) 263 (defun custom-declare-group (symbol members doc &rest args)
167 "Like `defgroup', but SYMBOL is evaluated as a normal argument." 264 "Like `defgroup', but SYMBOL is evaluated as a normal argument."
265 (while members
266 (apply 'custom-add-to-group symbol (car members))
267 (setq members (cdr members)))
168 (put symbol 'custom-group (nconc members (get symbol 'custom-group))) 268 (put symbol 'custom-group (nconc members (get symbol 'custom-group)))
169 (when doc 269 (when doc
170 (put symbol 'group-documentation doc)) 270 (put symbol 'group-documentation doc))
171 (while args 271 (while args
172 (let ((arg (car args))) 272 (let ((arg (car args)))
204 The following KEYWORD's are defined: 304 The following KEYWORD's are defined:
205 305
206 :group VALUE should be a customization group. 306 :group VALUE should be a customization group.
207 Add SYMBOL to that group. 307 Add SYMBOL to that group.
208 308
209 Read the section about customization in the emacs lisp manual for more 309 Read the section about customization in the Emacs Lisp manual for more
210 information." 310 information."
211 `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) 311 `(custom-declare-group (quote ,symbol) ,members ,doc ,@args))
212 312
213 (defun custom-add-to-group (group option widget) 313 (defun custom-add-to-group (group option widget)
214 "To existing GROUP add a new OPTION of type WIDGET. 314 "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 385 If NOW is present and non-nil, VALUE is also evaluated and bound as
286 the default value for the SYMBOL." 386 the default value for the SYMBOL."
287 (while args 387 (while args
288 (let ((entry (car args))) 388 (let ((entry (car args)))
289 (if (listp entry) 389 (if (listp entry)
290 (let ((symbol (nth 0 entry)) 390 (let* ((symbol (nth 0 entry))
291 (value (nth 1 entry)) 391 (value (nth 1 entry))
292 (now (nth 2 entry))) 392 (now (nth 2 entry))
393 (requests (nth 3 entry))
394 (set (or (get symbol 'custom-set) 'set-default)))
293 (put symbol 'saved-value (list value)) 395 (put symbol 'saved-value (list value))
294 (cond (now 396 (cond (now
295 ;; Rogue variable, set it now. 397 ;; Rogue variable, set it now.
296 (put symbol 'force-value t) 398 (put symbol 'force-value t)
297 (set-default symbol (eval value))) 399 (funcall set symbol (eval value)))
298 ((default-boundp symbol) 400 ((default-boundp symbol)
299 ;; Something already set this, overwrite it. 401 ;; Something already set this, overwrite it.
300 (set-default symbol (eval value)))) 402 (funcall set symbol (eval value))))
403 (when requests
404 (put symbol 'custom-requests requests)
405 (mapcar 'require requests))
301 (setq args (cdr args))) 406 (setq args (cdr args)))
302 ;; Old format, a plist of SYMBOL VALUE pairs. 407 ;; Old format, a plist of SYMBOL VALUE pairs.
303 (message "Warning: old format `custom-set-variables'") 408 (message "Warning: old format `custom-set-variables'")
304 (ding) 409 (ding)
305 (sit-for 2) 410 (sit-for 2)