|
13401
|
1 ;;; custom.el --- User friendly customization support.
|
|
14169
|
2
|
|
13401
|
3 ;; Copyright (C) 1995 Free Software Foundation, Inc.
|
|
14169
|
4
|
|
13401
|
5 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
|
|
|
6 ;; Keywords: help
|
|
|
7 ;; Version: 0.5
|
|
|
8
|
|
14169
|
9 ;; This file is part of GNU Emacs.
|
|
|
10
|
|
|
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
12 ;; it under the terms of the GNU General Public License as published by
|
|
|
13 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
14 ;; any later version.
|
|
|
15
|
|
|
16 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
19 ;; GNU General Public License for more details.
|
|
|
20
|
|
|
21 ;; You should have received a copy of the GNU General Public License
|
|
|
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
24 ;; Boston, MA 02111-1307, USA.
|
|
|
25
|
|
13401
|
26 ;;; Commentary:
|
|
14169
|
27
|
|
13401
|
28 ;; WARNING: This package is still under construction and not all of
|
|
|
29 ;; the features below are implemented.
|
|
|
30 ;;
|
|
|
31 ;; This package provides a framework for adding user friendly
|
|
|
32 ;; customization support to Emacs. Having to do customization by
|
|
|
33 ;; editing a text file in some arcane syntax is user hostile in the
|
|
|
34 ;; extreme, and to most users emacs lisp definitely count as arcane.
|
|
|
35 ;;
|
|
14032
|
36 ;; The intent is that authors of emacs lisp packages declare the
|
|
13401
|
37 ;; variables intended for user customization with `custom-declare'.
|
|
|
38 ;; Custom can then automatically generate a customization buffer with
|
|
|
39 ;; `custom-buffer-create' where the user can edit the package
|
|
|
40 ;; variables in a simple and intuitive way, as well as a menu with
|
|
|
41 ;; `custom-menu-create' where he can set the more commonly used
|
|
|
42 ;; variables interactively.
|
|
|
43 ;;
|
|
|
44 ;; It is also possible to use custom for modifying the properties of
|
|
|
45 ;; other objects than the package itself, by specifying extra optional
|
|
|
46 ;; arguments to `custom-buffer-create'.
|
|
|
47 ;;
|
|
|
48 ;; Custom is inspired by OPEN LOOK property windows.
|
|
|
49
|
|
|
50 ;;; Todo:
|
|
|
51 ;;
|
|
|
52 ;; - Toggle documentation in three states `none', `one-line', `full'.
|
|
|
53 ;; - Function to generate an XEmacs menu from a CUSTOM.
|
|
|
54 ;; - Write TeXinfo documentation.
|
|
|
55 ;; - Make it possible to hide sections by clicking at the level.
|
|
|
56 ;; - Declare AUC TeX variables.
|
|
|
57 ;; - Declare (ding) Gnus variables.
|
|
|
58 ;; - Declare Emacs variables.
|
|
|
59 ;; - Implement remaining types.
|
|
|
60 ;; - XEmacs port.
|
|
|
61 ;; - Allow `URL', `info', and internal hypertext buttons.
|
|
|
62 ;; - Support meta-variables and goal directed customization.
|
|
|
63 ;; - Make it easy to declare custom types independently.
|
|
|
64 ;; - Make it possible to declare default value and type for a single
|
|
|
65 ;; variable, storing the data in a symbol property.
|
|
|
66 ;; - Syntactic sugar for CUSTOM declarations.
|
|
14032
|
67 ;; - Use W3 for variable documentation.
|
|
13401
|
68
|
|
|
69 ;;; Code:
|
|
|
70
|
|
|
71 ;;; Compatibility:
|
|
|
72
|
|
|
73 (or (fboundp 'buffer-substring-no-properties)
|
|
|
74 ;; Introduced in Emacs 19.29.
|
|
|
75 (defun buffer-substring-no-properties (beg end)
|
|
|
76 "Return the text from BEG to END, without text properties, as a string."
|
|
|
77 (let ((string (buffer-substring beg end)))
|
|
|
78 (set-text-properties 0 (length string) nil string)
|
|
|
79 string)))
|
|
|
80
|
|
|
81 (or (fboundp 'add-to-list)
|
|
|
82 ;; Introduced in Emacs 19.29.
|
|
|
83 (defun add-to-list (list-var element)
|
|
|
84 "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
|
|
|
85 If you want to use `add-to-list' on a variable that is not defined
|
|
|
86 until a certain package is loaded, you should put the call to `add-to-list'
|
|
|
87 into a hook function that will be run only after loading the package.
|
|
|
88 `eval-after-load' provides one way to do this. In some cases
|
|
|
89 other hooks, such as major mode hooks, can do the job."
|
|
|
90 (or (member element (symbol-value list-var))
|
|
|
91 (set list-var (cons element (symbol-value list-var))))))
|
|
|
92
|
|
|
93 (or (fboundp 'plist-get)
|
|
|
94 ;; Introduced in Emacs 19.29.
|
|
|
95 (defun plist-get (plist prop)
|
|
|
96 "Extract a value from a property list.
|
|
|
97 PLIST is a property list, which is a list of the form
|
|
|
98 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
|
|
|
99 corresponding to the given PROP, or nil if PROP is not
|
|
|
100 one of the properties on the list."
|
|
|
101 (let (result)
|
|
|
102 (while plist
|
|
|
103 (if (eq (car plist) prop)
|
|
|
104 (setq result (car (cdr plist))
|
|
|
105 plist nil)
|
|
|
106 (set plist (cdr (cdr plist)))))
|
|
|
107 result)))
|
|
|
108
|
|
|
109 (or (fboundp 'plist-put)
|
|
|
110 ;; Introduced in Emacs 19.29.
|
|
|
111 (defun plist-put (plist prop val)
|
|
|
112 "Change value in PLIST of PROP to VAL.
|
|
|
113 PLIST is a property list, which is a list of the form
|
|
|
114 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
|
|
|
115 If PROP is already a property on the list, its value is set to VAL,
|
|
|
116 otherwise the new PROP VAL pair is added. The new plist is returned;
|
|
|
117 use `(setq x (plist-put x prop val))' to be sure to use the new value.
|
|
|
118 The PLIST is modified by side effects."
|
|
|
119 (if (null plist)
|
|
|
120 (list prop val)
|
|
|
121 (let ((current plist))
|
|
|
122 (while current
|
|
|
123 (cond ((eq (car current) prop)
|
|
|
124 (setcar (cdr current) val)
|
|
|
125 (setq current nil))
|
|
|
126 ((null (cdr (cdr current)))
|
|
|
127 (setcdr (cdr current) (list prop val))
|
|
|
128 (setq current nil))
|
|
|
129 (t
|
|
|
130 (setq current (cdr (cdr current)))))))
|
|
|
131 plist)))
|
|
|
132
|
|
|
133 (or (fboundp 'match-string)
|
|
|
134 ;; Introduced in Emacs 19.29.
|
|
|
135 (defun match-string (num &optional string)
|
|
|
136 "Return string of text matched by last search.
|
|
|
137 NUM specifies which parenthesized expression in the last regexp.
|
|
|
138 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
|
|
|
139 Zero means the entire text matched by the whole regexp or whole string.
|
|
|
140 STRING should be given if the last search was by `string-match' on STRING."
|
|
|
141 (if (match-beginning num)
|
|
|
142 (if string
|
|
|
143 (substring string (match-beginning num) (match-end num))
|
|
|
144 (buffer-substring (match-beginning num) (match-end num))))))
|
|
|
145
|
|
|
146 (or (fboundp 'facep)
|
|
|
147 ;; Introduced in Emacs 19.29.
|
|
|
148 (defun facep (x)
|
|
|
149 "Return t if X is a face name or an internal face vector."
|
|
|
150 (and (or (and (fboundp 'internal-facep) (internal-facep x))
|
|
|
151 (and
|
|
|
152 (symbolp x)
|
|
|
153 (assq x (and (boundp 'global-face-data) global-face-data))))
|
|
|
154 t)))
|
|
|
155
|
|
|
156 ;; XEmacs and Emacs 19.29 facep does different things.
|
|
|
157 (if (fboundp 'find-face)
|
|
|
158 (fset 'custom-facep 'find-face)
|
|
|
159 (fset 'custom-facep 'facep))
|
|
|
160
|
|
|
161 (if (custom-facep 'underline)
|
|
|
162 ()
|
|
|
163 ;; No underline face in XEmacs 19.12.
|
|
|
164 (and (fboundp 'make-face)
|
|
|
165 (funcall (intern "make-face") 'underline))
|
|
|
166 ;; Must avoid calling set-face-underline-p directly, because it
|
|
|
167 ;; is a defsubst in emacs19, and will make the .elc files non
|
|
|
168 ;; portable!
|
|
|
169 (or (and (fboundp 'face-differs-from-default-p)
|
|
|
170 (face-differs-from-default-p 'underline))
|
|
|
171 (and (fboundp 'set-face-underline-p)
|
|
|
172 (funcall 'set-face-underline-p 'underline t))))
|
|
|
173
|
|
|
174 (or (fboundp 'set-text-properties)
|
|
|
175 ;; Missing in XEmacs 19.12.
|
|
|
176 (defun set-text-properties (start end props &optional buffer)
|
|
|
177 (if (or (null buffer) (bufferp buffer))
|
|
|
178 (if props
|
|
|
179 (while props
|
|
|
180 (put-text-property
|
|
|
181 start end (car props) (nth 1 props) buffer)
|
|
|
182 (setq props (nthcdr 2 props)))
|
|
|
183 (remove-text-properties start end ())))))
|
|
|
184
|
|
|
185 (or (fboundp 'event-closest-point)
|
|
|
186 ;; Missing in Emacs 19.29.
|
|
|
187 (defun event-point (event)
|
|
|
188 "Return the character position of the given mouse-motion, button-press,
|
|
|
189 or button-release event. If the event did not occur over a window, or did
|
|
|
190 not occur over text, then this returns nil. Otherwise, it returns an index
|
|
|
191 into the buffer visible in the event's window."
|
|
|
192 (posn-point (event-start event))))
|
|
|
193
|
|
|
194 (eval-when-compile
|
|
|
195 (defvar x-colors nil)
|
|
|
196 (defvar custom-button-face nil)
|
|
|
197 (defvar custom-field-uninitialized-face nil)
|
|
|
198 (defvar custom-field-invalid-face nil)
|
|
|
199 (defvar custom-field-modified-face nil)
|
|
|
200 (defvar custom-field-face nil)
|
|
|
201 (defvar custom-mouse-face nil)
|
|
|
202 (defvar custom-field-active-face nil))
|
|
|
203
|
|
|
204 (or (and (fboundp 'modify-face) (not (featurep 'face-lock)))
|
|
|
205 ;; Introduced in Emacs 19.29. Incompatible definition also introduced
|
|
|
206 ;; by face-lock.el version 3.00 and above for Emacs 19.28 and below.
|
|
|
207 ;; face-lock does not call modify-face, so we can safely redefine it.
|
|
|
208 (defun modify-face (face foreground background stipple
|
|
|
209 bold-p italic-p underline-p)
|
|
|
210 "Change the display attributes for face FACE.
|
|
|
211 FOREGROUND and BACKGROUND should be color strings or nil.
|
|
|
212 STIPPLE should be a stipple pattern name or nil.
|
|
|
213 BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
|
|
|
214 in italic, and underlined, respectively. (Yes if non-nil.)
|
|
|
215 If called interactively, prompts for a face and face attributes."
|
|
|
216 (interactive
|
|
|
217 (let* ((completion-ignore-case t)
|
|
|
218 (face (symbol-name (read-face-name "Modify face: ")))
|
|
|
219 (colors (mapcar 'list x-colors))
|
|
|
220 (stipples (mapcar 'list
|
|
|
221 (apply 'nconc
|
|
|
222 (mapcar 'directory-files
|
|
|
223 x-bitmap-file-path))))
|
|
|
224 (foreground (modify-face-read-string
|
|
|
225 face (face-foreground (intern face))
|
|
|
226 "foreground" colors))
|
|
|
227 (background (modify-face-read-string
|
|
|
228 face (face-background (intern face))
|
|
|
229 "background" colors))
|
|
|
230 (stipple (modify-face-read-string
|
|
|
231 face (face-stipple (intern face))
|
|
|
232 "stipple" stipples))
|
|
|
233 (bold-p (y-or-n-p (concat "Set face " face " bold ")))
|
|
|
234 (italic-p (y-or-n-p (concat "Set face " face " italic ")))
|
|
|
235 (underline-p (y-or-n-p (concat "Set face " face " underline "))))
|
|
|
236 (message "Face %s: %s" face
|
|
|
237 (mapconcat 'identity
|
|
|
238 (delq nil
|
|
|
239 (list (and foreground (concat (downcase foreground) " foreground"))
|
|
|
240 (and background (concat (downcase background) " background"))
|
|
|
241 (and stipple (concat (downcase stipple) " stipple"))
|
|
|
242 (and bold-p "bold") (and italic-p "italic")
|
|
|
243 (and underline-p "underline"))) ", "))
|
|
|
244 (list (intern face) foreground background stipple
|
|
|
245 bold-p italic-p underline-p)))
|
|
|
246 (condition-case nil (set-face-foreground face foreground) (error nil))
|
|
|
247 (condition-case nil (set-face-background face background) (error nil))
|
|
|
248 (condition-case nil (set-face-stipple face stipple) (error nil))
|
|
|
249 (if (string-match "XEmacs" emacs-version)
|
|
|
250 (progn
|
|
|
251 (funcall (if bold-p 'make-face-bold 'make-face-unbold) face)
|
|
|
252 (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face))
|
|
|
253 (funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t)
|
|
|
254 (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t))
|
|
|
255 (set-face-underline-p face underline-p)
|
|
|
256 (and (interactive-p) (redraw-display))))
|
|
|
257
|
|
|
258 ;; We can't easily check for a working intangible.
|
|
|
259 (defconst intangible (if (and (boundp 'emacs-minor-version)
|
|
|
260 (or (> emacs-major-version 19)
|
|
|
261 (and (> emacs-major-version 18)
|
|
|
262 (> emacs-minor-version 28))))
|
|
|
263 (setq intangible 'intangible)
|
|
|
264 (setq intangible 'intangible-if-it-had-been-working))
|
|
14032
|
265 "The symbol making text intangible.")
|
|
13401
|
266
|
|
|
267 (defconst rear-nonsticky (if (string-match "XEmacs" emacs-version)
|
|
|
268 'end-open
|
|
|
269 'rear-nonsticky)
|
|
14032
|
270 "The symbol making text properties non-sticky in the rear end.")
|
|
13401
|
271
|
|
|
272 (defconst front-sticky (if (string-match "XEmacs" emacs-version)
|
|
|
273 'front-closed
|
|
|
274 'front-sticky)
|
|
|
275 "The symbol making text properties sticky in the front.")
|
|
|
276
|
|
|
277 (defconst mouse-face (if (string-match "XEmacs" emacs-version)
|
|
|
278 'highlight
|
|
|
279 'mouse-face)
|
|
|
280 "Symbol used for highlighting text under mouse.")
|
|
|
281
|
|
|
282 ;; Put it in the Help menu, if possible.
|
|
|
283 (if (string-match "XEmacs" emacs-version)
|
|
|
284 ;; XEmacs (disabled because it doesn't work)
|
|
|
285 (and current-menubar
|
|
|
286 (add-menu-item '("Help") "Customize..." 'customize nil))
|
|
|
287 ;; Emacs 19.28 and earlier
|
|
|
288 (global-set-key [ menu-bar help customize ]
|
|
|
289 '("Customize..." . customize))
|
|
|
290 ;; Emacs 19.29 and later
|
|
|
291 (global-set-key [ menu-bar help-menu customize ]
|
|
|
292 '("Customize..." . customize)))
|
|
|
293
|
|
|
294 ;; XEmacs popup-menu stolen from w3.el.
|
|
|
295 (defun custom-x-really-popup-menu (pos title menudesc)
|
|
|
296 "My hacked up function to do a blocking popup menu..."
|
|
|
297 (let ((echo-keystrokes 0)
|
|
|
298 event menu)
|
|
|
299 (while menudesc
|
|
|
300 (setq menu (cons (vector (car (car menudesc))
|
|
|
301 (list (car (car menudesc))) t) menu)
|
|
|
302 menudesc (cdr menudesc)))
|
|
|
303 (setq menu (cons title menu))
|
|
|
304 (popup-menu menu)
|
|
|
305 (catch 'popup-done
|
|
|
306 (while t
|
|
|
307 (setq event (next-command-event event))
|
|
|
308 (cond ((and (misc-user-event-p event) (stringp (car-safe (event-object event))))
|
|
|
309 (throw 'popup-done (event-object event)))
|
|
|
310 ((and (misc-user-event-p event)
|
|
|
311 (or (eq (event-object event) 'abort)
|
|
|
312 (eq (event-object event) 'menu-no-selection-hook)))
|
|
|
313 nil)
|
|
|
314 ((not (popup-menu-up-p))
|
|
|
315 (throw 'popup-done nil))
|
|
|
316 ((button-release-event-p event);; don't beep twice
|
|
|
317 nil)
|
|
|
318 (t
|
|
|
319 (beep)
|
|
|
320 (message "please make a choice from the menu.")))))))
|
|
|
321
|
|
|
322 ;;; Categories:
|
|
|
323 ;;
|
|
|
324 ;; XEmacs use inheritable extents for the same purpose as Emacs uses
|
|
|
325 ;; the category text property.
|
|
|
326
|
|
|
327 (if (string-match "XEmacs" emacs-version)
|
|
|
328 (progn
|
|
|
329 ;; XEmacs categories.
|
|
|
330 (defun custom-category-create (name)
|
|
|
331 (set name (make-extent nil nil))
|
|
|
332 "Create a text property category named NAME.")
|
|
|
333
|
|
|
334 (defun custom-category-put (name property value)
|
|
|
335 "In CATEGORY set PROPERTY to VALUE."
|
|
|
336 (set-extent-property (symbol-value name) property value))
|
|
|
337
|
|
|
338 (defun custom-category-get (name property)
|
|
|
339 "In CATEGORY get PROPERTY."
|
|
|
340 (extent-property (symbol-value name) property))
|
|
|
341
|
|
|
342 (defun custom-category-set (from to category)
|
|
|
343 "Make text between FROM and TWO have category CATEGORY."
|
|
|
344 (let ((extent (make-extent from to)))
|
|
|
345 (set-extent-parent extent (symbol-value category)))))
|
|
|
346
|
|
|
347 ;; Emacs categories.
|
|
|
348 (defun custom-category-create (name)
|
|
|
349 "Create a text property category named NAME."
|
|
|
350 (set name name))
|
|
|
351
|
|
|
352 (defun custom-category-put (name property value)
|
|
|
353 "In CATEGORY set PROPERTY to VALUE."
|
|
|
354 (put name property value))
|
|
|
355
|
|
|
356 (defun custom-category-get (name property)
|
|
|
357 "In CATEGORY get PROPERTY."
|
|
|
358 (get name property))
|
|
|
359
|
|
|
360 (defun custom-category-set (from to category)
|
|
|
361 "Make text between FROM and TWO have category CATEGORY."
|
|
|
362 (put-text-property from to 'category category)))
|
|
|
363
|
|
|
364 ;;; External Data:
|
|
|
365 ;;
|
|
|
366 ;; The following functions and variables defines the interface for
|
|
|
367 ;; connecting a CUSTOM with an external entity, by default an emacs
|
|
|
368 ;; lisp variable.
|
|
|
369
|
|
|
370 (defvar custom-external 'default-value
|
|
|
371 "Function returning the external value of NAME.")
|
|
|
372
|
|
|
373 (defvar custom-external-set 'set-default
|
|
|
374 "Function setting the external value of NAME to VALUE.")
|
|
|
375
|
|
|
376 (defun custom-external (name)
|
|
|
377 "Get the external value associated with NAME."
|
|
|
378 (funcall custom-external name))
|
|
|
379
|
|
|
380 (defun custom-external-set (name value)
|
|
|
381 "Set the external value associated with NAME to VALUE."
|
|
|
382 (funcall custom-external-set name value))
|
|
|
383
|
|
|
384 (defvar custom-name-fields nil
|
|
|
385 "Alist of custom names and their associated editing field.")
|
|
|
386 (make-variable-buffer-local 'custom-name-fields)
|
|
|
387
|
|
|
388 (defun custom-name-enter (name field)
|
|
|
389 "Associate NAME with FIELD."
|
|
|
390 (if (null name)
|
|
|
391 ()
|
|
|
392 (custom-assert 'field)
|
|
|
393 (setq custom-name-fields (cons (cons name field) custom-name-fields))))
|
|
|
394
|
|
|
395 (defun custom-name-field (name)
|
|
|
396 "The editing field associated with NAME."
|
|
|
397 (cdr (assq name custom-name-fields)))
|
|
|
398
|
|
|
399 (defun custom-name-value (name)
|
|
|
400 "The value currently displayed for NAME in the customization buffer."
|
|
|
401 (let* ((field (custom-name-field name))
|
|
|
402 (custom (custom-field-custom field)))
|
|
|
403 (custom-field-parse field)
|
|
|
404 (funcall (custom-property custom 'export) custom
|
|
|
405 (car (custom-field-extract custom field)))))
|
|
|
406
|
|
|
407 (defvar custom-save 'custom-save
|
|
|
408 "Function that will save current customization buffer.")
|
|
|
409
|
|
|
410 ;;; Custom Functions:
|
|
|
411 ;;
|
|
|
412 ;; The following functions are part of the public interface to the
|
|
|
413 ;; CUSTOM datastructure. Each CUSTOM describes a group of variables,
|
|
|
414 ;; a single variable, or a component of a structured variable. The
|
|
14032
|
415 ;; CUSTOM instances are part of two hierarchies, the first is the
|
|
13401
|
416 ;; `part-of' hierarchy in which each CUSTOM is a component of another
|
|
|
417 ;; CUSTOM, except for the top level CUSTOM which is contained in
|
|
14032
|
418 ;; `custom-data'. The second hierarchy is a `is-a' type hierarchy
|
|
13401
|
419 ;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
|
|
|
420 ;; property and `custom-type-properties'.
|
|
|
421
|
|
14032
|
422 (defvar custom-file (convert-standard-filename "~/.custom.el")
|
|
13401
|
423 "Name of file with customization information.")
|
|
|
424
|
|
|
425 (defconst custom-data
|
|
|
426 '((tag . "Emacs")
|
|
|
427 (doc . "The extensible self-documenting text editor.")
|
|
|
428 (type . group)
|
|
|
429 (data "\n"
|
|
|
430 ((header . nil)
|
|
|
431 (compact . t)
|
|
|
432 (type . group)
|
|
|
433 (doc . "\
|
|
|
434 Press [Save] to save any changes permanently after you are done editing.
|
|
|
435 You can load customization information from other files by editing the
|
|
|
436 `File' field and pressing the [Load] button. When you press [Save] the
|
|
|
437 customization information of all files you have loaded, plus any
|
|
|
438 changes you might have made manually, will be stored in the file
|
|
|
439 specified by the `File' field.")
|
|
|
440 (data ((tag . "Load")
|
|
|
441 (type . button)
|
|
|
442 (query . custom-load))
|
|
|
443 ((tag . "Save")
|
|
|
444 (type . button)
|
|
|
445 (query . custom-save))
|
|
|
446 ((name . custom-file)
|
|
|
447 (default . "~/.custom.el")
|
|
|
448 (doc . "Name of file with customization information.\n")
|
|
|
449 (tag . "File")
|
|
|
450 (type . file))))))
|
|
|
451 "The global customization information.
|
|
|
452 A custom association list.")
|
|
|
453
|
|
|
454 (defun custom-declare (path custom)
|
|
|
455 "Declare variables for customization.
|
|
|
456 PATH is a list of tags leading to the place in the customization
|
|
|
457 hierarchy the new entry should be added. CUSTOM is the entry to add."
|
|
|
458 (custom-initialize custom)
|
|
|
459 (let ((current (custom-travel-path custom-data path)))
|
|
|
460 (or (member custom (custom-data current))
|
|
|
461 (nconc (custom-data current) (list custom)))))
|
|
|
462
|
|
|
463 (put 'custom-declare 'lisp-indent-hook 1)
|
|
|
464
|
|
|
465 (defconst custom-type-properties
|
|
|
466 '((repeat (type . default)
|
|
|
467 ;; See `custom-match'.
|
|
|
468 (import . custom-repeat-import)
|
|
|
469 (eval . custom-repeat-eval)
|
|
|
470 (quote . custom-repeat-quote)
|
|
|
471 (accept . custom-repeat-accept)
|
|
|
472 (extract . custom-repeat-extract)
|
|
|
473 (validate . custom-repeat-validate)
|
|
|
474 (insert . custom-repeat-insert)
|
|
|
475 (match . custom-repeat-match)
|
|
|
476 (query . custom-repeat-query)
|
|
|
477 (prefix . "")
|
|
|
478 (del-tag . "[DEL]")
|
|
|
479 (add-tag . "[INS]"))
|
|
|
480 (pair (type . group)
|
|
|
481 ;; A cons-cell.
|
|
|
482 (accept . custom-pair-accept)
|
|
|
483 (eval . custom-pair-eval)
|
|
|
484 (import . custom-pair-import)
|
|
|
485 (quote . custom-pair-quote)
|
|
|
486 (valid . (lambda (c d) (consp d)))
|
|
|
487 (extract . custom-pair-extract))
|
|
|
488 (list (type . group)
|
|
|
489 ;; A lisp list.
|
|
|
490 (quote . custom-list-quote)
|
|
|
491 (valid . (lambda (c d)
|
|
|
492 (listp d)))
|
|
|
493 (extract . custom-list-extract))
|
|
|
494 (group (type . default)
|
|
|
495 ;; See `custom-match'.
|
|
|
496 (face-tag . nil)
|
|
|
497 (eval . custom-group-eval)
|
|
|
498 (import . custom-group-import)
|
|
|
499 (initialize . custom-group-initialize)
|
|
|
500 (apply . custom-group-apply)
|
|
|
501 (reset . custom-group-reset)
|
|
|
502 (factory-reset . custom-group-factory-reset)
|
|
|
503 (extract . nil)
|
|
|
504 (validate . custom-group-validate)
|
|
|
505 (query . custom-toggle-hide)
|
|
|
506 (accept . custom-group-accept)
|
|
|
507 (insert . custom-group-insert)
|
|
|
508 (find . custom-group-find))
|
|
|
509 (toggle (type . choice)
|
|
|
510 ;; Booleans.
|
|
|
511 (data ((type . const)
|
|
|
512 (tag . "On ")
|
|
|
513 (default . t))
|
|
|
514 ((type . const)
|
|
|
515 (tag . "Off")
|
|
|
516 (default . nil))))
|
|
14851
|
517 (triggle (type . choice)
|
|
|
518 ;; On/Off/Default.
|
|
|
519 (data ((type . const)
|
|
|
520 (tag . "On ")
|
|
|
521 (default . t))
|
|
|
522 ((type . const)
|
|
|
523 (tag . "Off")
|
|
|
524 (default . nil))
|
|
|
525 ((type . const)
|
|
|
526 (tag . "Def")
|
|
|
527 (default . as-is))))
|
|
13401
|
528 (choice (type . default)
|
|
|
529 ;; See `custom-match'.
|
|
|
530 (query . custom-choice-query)
|
|
|
531 (accept . custom-choice-accept)
|
|
|
532 (extract . custom-choice-extract)
|
|
|
533 (validate . custom-choice-validate)
|
|
|
534 (insert . custom-choice-insert)
|
|
|
535 (none (tag . "Unknown")
|
|
|
536 (default . __uninitialized__)
|
|
|
537 (type . const)))
|
|
|
538 (const (type . default)
|
|
|
539 ;; A `const' only matches a single lisp value.
|
|
|
540 (extract . (lambda (c f) (list (custom-default c))))
|
|
|
541 (validate . (lambda (c f) nil))
|
|
|
542 (valid . custom-const-valid)
|
|
|
543 (update . custom-const-update)
|
|
|
544 (insert . custom-const-insert))
|
|
|
545 (face-doc (type . doc)
|
|
|
546 ;; A variable containing a face.
|
|
|
547 (doc . "\
|
|
|
548 You can customize the look of Emacs by deciding which faces should be
|
|
|
549 used when. If you push one of the face buttons below, you will be
|
|
|
550 given a choice between a number of standard faces. The name of the
|
|
|
551 selected face is shown right after the face button, and it is
|
|
|
552 displayed its own face so you can see how it looks. If you know of
|
|
|
553 another standard face not listed and want to use it, you can select
|
|
|
554 `Other' and write the name in the editing field.
|
|
|
555
|
|
|
556 If none of the standard faces suits you, you can select `Customize' to
|
|
|
557 create your own face. This will make six fields appear under the face
|
|
|
558 button. The `Fg' and `Bg' fields are the foreground and background
|
|
|
559 colors for the face, respectively. You should type the name of the
|
|
|
560 color in the field. You can use any X11 color name. A list of X11
|
|
|
561 color names may be available in the file `/usr/lib/X11/rgb.txt' on
|
|
|
562 your system. The special color name `default' means that the face
|
|
|
563 will not change the color of the text. The `Stipple' field is weird,
|
|
|
564 so just ignore it. The three remaining fields are toggles, which will
|
|
|
565 make the text `bold', `italic', or `underline' respectively. For some
|
|
|
566 fonts `bold' or `italic' will not make any visible change."))
|
|
|
567 (face (type . choice)
|
|
|
568 (eval . custom-face-eval)
|
|
|
569 (import . custom-face-import)
|
|
|
570 (data ((tag . "None")
|
|
|
571 (default . nil)
|
|
|
572 (type . const))
|
|
|
573 ((tag . "Default")
|
|
|
574 (default . default)
|
|
|
575 (face . custom-const-face)
|
|
|
576 (type . const))
|
|
|
577 ((tag . "Bold")
|
|
|
578 (default . bold)
|
|
|
579 (face . custom-const-face)
|
|
|
580 (type . const))
|
|
|
581 ((tag . "Bold-italic")
|
|
|
582 (default . bold-italic)
|
|
|
583 (face . custom-const-face)
|
|
|
584 (type . const))
|
|
|
585 ((tag . "Italic")
|
|
|
586 (default . italic)
|
|
|
587 (face . custom-const-face)
|
|
|
588 (type . const))
|
|
|
589 ((tag . "Underline")
|
|
|
590 (default . underline)
|
|
|
591 (face . custom-const-face)
|
|
|
592 (type . const))
|
|
|
593 ((tag . "Highlight")
|
|
|
594 (default . highlight)
|
|
|
595 (face . custom-const-face)
|
|
|
596 (type . const))
|
|
|
597 ((tag . "Modeline")
|
|
|
598 (default . modeline)
|
|
|
599 (face . custom-const-face)
|
|
|
600 (type . const))
|
|
|
601 ((tag . "Region")
|
|
|
602 (default . region)
|
|
|
603 (face . custom-const-face)
|
|
|
604 (type . const))
|
|
|
605 ((tag . "Secondary Selection")
|
|
|
606 (default . secondary-selection)
|
|
|
607 (face . custom-const-face)
|
|
|
608 (type . const))
|
|
|
609 ((tag . "Customized")
|
|
|
610 (compact . t)
|
|
|
611 (face-tag . custom-face-hack)
|
|
|
612 (eval . custom-face-eval)
|
|
|
613 (data ((hidden . t)
|
|
|
614 (tag . "")
|
|
|
615 (doc . "\
|
|
|
616 Select the properties you want this face to have.")
|
|
|
617 (default . custom-face-lookup)
|
|
|
618 (type . const))
|
|
|
619 "\n"
|
|
|
620 ((tag . "Fg")
|
|
|
621 (hidden . t)
|
|
|
622 (default . "default")
|
|
|
623 (width . 20)
|
|
|
624 (type . string))
|
|
|
625 ((tag . "Bg")
|
|
|
626 (default . "default")
|
|
|
627 (width . 20)
|
|
|
628 (type . string))
|
|
|
629 ((tag . "Stipple")
|
|
|
630 (default . "default")
|
|
|
631 (width . 20)
|
|
|
632 (type . string))
|
|
|
633 "\n"
|
|
|
634 ((tag . "Bold")
|
|
14851
|
635 (default . as-is)
|
|
|
636 (type . triggle))
|
|
13401
|
637 " "
|
|
|
638 ((tag . "Italic")
|
|
14851
|
639 (default . as-is)
|
|
|
640 (type . triggle))
|
|
13401
|
641 " "
|
|
|
642 ((tag . "Underline")
|
|
|
643 (hidden . t)
|
|
14851
|
644 (default . as-is)
|
|
|
645 (type . triggle)))
|
|
13401
|
646 (default . (custom-face-lookup "default" "default" "default"
|
|
|
647 nil nil nil))
|
|
|
648 (type . list))
|
|
|
649 ((prompt . "Other")
|
|
|
650 (face . custom-field-value)
|
|
|
651 (default . __uninitialized__)
|
|
|
652 (type . symbol))))
|
|
|
653 (file (type . string)
|
|
|
654 ;; A string containing a file or directory name.
|
|
|
655 (directory . nil)
|
|
|
656 (default-file . nil)
|
|
|
657 (query . custom-file-query))
|
|
|
658 (sexp (type . default)
|
|
|
659 ;; Any lisp expression.
|
|
|
660 (width . 40)
|
|
|
661 (default . (__uninitialized__ . "Uninitialized"))
|
|
|
662 (read . custom-sexp-read)
|
|
|
663 (write . custom-sexp-write))
|
|
|
664 (symbol (type . sexp)
|
|
|
665 ;; A lisp symbol.
|
|
|
666 (width . 40)
|
|
|
667 (valid . (lambda (c d) (symbolp d))))
|
|
|
668 (integer (type . sexp)
|
|
|
669 ;; A lisp integer.
|
|
|
670 (width . 10)
|
|
|
671 (valid . (lambda (c d) (integerp d))))
|
|
|
672 (string (type . default)
|
|
|
673 ;; A lisp string.
|
|
|
674 (width . 40)
|
|
|
675 (valid . (lambda (c d) (stringp d)))
|
|
|
676 (read . custom-string-read)
|
|
|
677 (write . custom-string-write))
|
|
|
678 (button (type . default)
|
|
|
679 ;; Push me.
|
|
|
680 (accept . ignore)
|
|
|
681 (extract . nil)
|
|
|
682 (validate . ignore)
|
|
|
683 (insert . custom-button-insert))
|
|
|
684 (doc (type . default)
|
|
|
685 ;; A documentation only entry with no value.
|
|
|
686 (header . nil)
|
|
|
687 (reset . ignore)
|
|
|
688 (extract . nil)
|
|
|
689 (validate . ignore)
|
|
|
690 (insert . custom-documentation-insert))
|
|
|
691 (default (width . 20)
|
|
|
692 (valid . (lambda (c v) t))
|
|
|
693 (insert . custom-default-insert)
|
|
|
694 (update . custom-default-update)
|
|
|
695 (query . custom-default-query)
|
|
|
696 (tag . nil)
|
|
|
697 (prompt . nil)
|
|
|
698 (doc . nil)
|
|
|
699 (header . t)
|
|
|
700 (padding . ? )
|
|
|
701 (quote . custom-default-quote)
|
|
|
702 (eval . (lambda (c v) nil))
|
|
|
703 (export . custom-default-export)
|
|
|
704 (import . (lambda (c v) (list v)))
|
|
|
705 (synchronize . ignore)
|
|
|
706 (initialize . custom-default-initialize)
|
|
|
707 (extract . custom-default-extract)
|
|
|
708 (validate . custom-default-validate)
|
|
|
709 (apply . custom-default-apply)
|
|
|
710 (reset . custom-default-reset)
|
|
|
711 (factory-reset . custom-default-factory-reset)
|
|
|
712 (accept . custom-default-accept)
|
|
|
713 (match . custom-default-match)
|
|
|
714 (name . nil)
|
|
|
715 (compact . nil)
|
|
|
716 (hidden . nil)
|
|
|
717 (face . custom-default-face)
|
|
|
718 (data . nil)
|
|
|
719 (calculate . nil)
|
|
|
720 (default . __uninitialized__)))
|
|
|
721 "Alist of default properties for type symbols.
|
|
|
722 The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.")
|
|
|
723
|
|
|
724 (defconst custom-local-type-properties nil
|
|
|
725 "Local type properties.
|
|
|
726 Entries in this list take precedence over `custom-type-properties'.")
|
|
|
727
|
|
|
728 (make-variable-buffer-local 'custom-local-type-properties)
|
|
|
729
|
|
|
730 (defconst custom-nil '__uninitialized__
|
|
|
731 "Special value representing an uninitialized field.")
|
|
|
732
|
|
|
733 (defconst custom-invalid '__invalid__
|
|
|
734 "Special value representing an invalid field.")
|
|
|
735
|
|
|
736 (defun custom-property (custom property)
|
|
|
737 "Extract from CUSTOM property PROPERTY."
|
|
|
738 (let ((entry (assq property custom)))
|
|
|
739 (while (null entry)
|
|
|
740 ;; Look in superclass.
|
|
|
741 (let ((type (custom-type custom)))
|
|
|
742 (setq custom (cdr (or (assq type custom-local-type-properties)
|
|
|
743 (assq type custom-type-properties)))
|
|
|
744 entry (assq property custom))
|
|
|
745 (custom-assert 'custom)))
|
|
|
746 (cdr entry)))
|
|
|
747
|
|
|
748 (defun custom-super (custom property)
|
|
|
749 "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass."
|
|
|
750 (let ((entry nil))
|
|
|
751 (while (null entry)
|
|
|
752 ;; Look in superclass.
|
|
|
753 (let ((type (custom-type custom)))
|
|
|
754 (setq custom (cdr (or (assq type custom-local-type-properties)
|
|
|
755 (assq type custom-type-properties)))
|
|
|
756 entry (assq property custom))
|
|
|
757 (custom-assert 'custom)))
|
|
|
758 (cdr entry)))
|
|
|
759
|
|
|
760 (defun custom-property-set (custom property value)
|
|
14032
|
761 "Set CUSTOM PROPERTY to VALUE by side effect.
|
|
13401
|
762 CUSTOM must have at least one property already."
|
|
|
763 (let ((entry (assq property custom)))
|
|
|
764 (if entry
|
|
|
765 (setcdr entry value)
|
|
|
766 (setcdr custom (cons (cons property value) (cdr custom))))))
|
|
|
767
|
|
|
768 (defun custom-type (custom)
|
|
|
769 "Extract `type' from CUSTOM."
|
|
|
770 (cdr (assq 'type custom)))
|
|
|
771
|
|
|
772 (defun custom-name (custom)
|
|
|
773 "Extract `name' from CUSTOM."
|
|
|
774 (custom-property custom 'name))
|
|
|
775
|
|
|
776 (defun custom-tag (custom)
|
|
|
777 "Extract `tag' from CUSTOM."
|
|
|
778 (custom-property custom 'tag))
|
|
|
779
|
|
|
780 (defun custom-face-tag (custom)
|
|
|
781 "Extract `face-tag' from CUSTOM."
|
|
|
782 (custom-property custom 'face-tag))
|
|
|
783
|
|
|
784 (defun custom-prompt (custom)
|
|
|
785 "Extract `prompt' from CUSTOM.
|
|
|
786 If none exist, default to `tag' or, failing that, `type'."
|
|
|
787 (or (custom-property custom 'prompt)
|
|
|
788 (custom-property custom 'tag)
|
|
|
789 (capitalize (symbol-name (custom-type custom)))))
|
|
|
790
|
|
|
791 (defun custom-default (custom)
|
|
|
792 "Extract `default' from CUSTOM."
|
|
|
793 (let ((value (custom-property custom 'calculate)))
|
|
|
794 (if value
|
|
|
795 (eval value)
|
|
|
796 (custom-property custom 'default))))
|
|
|
797
|
|
|
798 (defun custom-data (custom)
|
|
|
799 "Extract the `data' from CUSTOM."
|
|
|
800 (custom-property custom 'data))
|
|
|
801
|
|
|
802 (defun custom-documentation (custom)
|
|
|
803 "Extract `doc' from CUSTOM."
|
|
|
804 (custom-property custom 'doc))
|
|
|
805
|
|
|
806 (defun custom-width (custom)
|
|
|
807 "Extract `width' from CUSTOM."
|
|
|
808 (custom-property custom 'width))
|
|
|
809
|
|
|
810 (defun custom-compact (custom)
|
|
|
811 "Extract `compact' from CUSTOM."
|
|
|
812 (custom-property custom 'compact))
|
|
|
813
|
|
|
814 (defun custom-padding (custom)
|
|
|
815 "Extract `padding' from CUSTOM."
|
|
|
816 (custom-property custom 'padding))
|
|
|
817
|
|
|
818 (defun custom-valid (custom value)
|
|
|
819 "Non-nil if CUSTOM may validly be set to VALUE."
|
|
|
820 (and (not (and (listp value) (eq custom-invalid (car value))))
|
|
|
821 (funcall (custom-property custom 'valid) custom value)))
|
|
|
822
|
|
|
823 (defun custom-import (custom value)
|
|
|
824 "Import CUSTOM VALUE from external variable.
|
|
|
825
|
|
|
826 This function change VALUE into a form that makes it easier to edit
|
|
|
827 internally. What the internal form is exactly depends on CUSTOM.
|
|
|
828 The internal form is returned."
|
|
|
829 (if (eq custom-nil value)
|
|
|
830 (list custom-nil)
|
|
|
831 (funcall (custom-property custom 'import) custom value)))
|
|
|
832
|
|
|
833 (defun custom-eval (custom value)
|
|
|
834 "Return non-nil if CUSTOM's VALUE needs to be evaluated."
|
|
|
835 (funcall (custom-property custom 'eval) custom value))
|
|
|
836
|
|
|
837 (defun custom-quote (custom value)
|
|
|
838 "Quote CUSTOM's VALUE if necessary."
|
|
|
839 (funcall (custom-property custom 'quote) custom value))
|
|
|
840
|
|
|
841 (defun custom-write (custom value)
|
|
|
842 "Convert CUSTOM VALUE to a string."
|
|
|
843 (cond ((eq value custom-nil)
|
|
|
844 "")
|
|
|
845 ((and (listp value) (eq (car value) custom-invalid))
|
|
|
846 (cdr value))
|
|
|
847 (t
|
|
|
848 (funcall (custom-property custom 'write) custom value))))
|
|
|
849
|
|
|
850 (defun custom-read (custom string)
|
|
|
851 "Convert CUSTOM field content STRING into lisp."
|
|
|
852 (condition-case nil
|
|
|
853 (funcall (custom-property custom 'read) custom string)
|
|
|
854 (error (cons custom-invalid string))))
|
|
|
855
|
|
|
856 (defun custom-match (custom values)
|
|
|
857 "Match CUSTOM with a list of VALUES.
|
|
|
858
|
|
|
859 Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
|
|
|
860 and the cdr is the remaining VALUES.
|
|
|
861
|
|
|
862 A CUSTOM is actually a regular expression over the alphabet of lisp
|
|
|
863 types. Most CUSTOM types are just doing a literal match, e.g. the
|
|
|
864 `symbol' type matches any lisp symbol. The exceptions are:
|
|
|
865
|
|
|
866 group: which corresponds to a `(' and `)' group in a regular expression.
|
|
|
867 choice: which corresponds to a group of `|' in a regular expression.
|
|
|
868 repeat: which corresponds to a `*' in a regular expression.
|
|
|
869 optional: which corresponds to a `?', and isn't implemented yet."
|
|
|
870 (if (memq values (list custom-nil nil))
|
|
|
871 ;; Nothing matches the uninitialized or empty list.
|
|
|
872 (cons custom-nil nil)
|
|
|
873 (funcall (custom-property custom 'match) custom values)))
|
|
|
874
|
|
|
875 (defun custom-initialize (custom)
|
|
|
876 "Initialize `doc' and `default' attributes of CUSTOM."
|
|
|
877 (funcall (custom-property custom 'initialize) custom))
|
|
|
878
|
|
|
879 (defun custom-find (custom tag)
|
|
|
880 "Find child in CUSTOM with `tag' TAG."
|
|
|
881 (funcall (custom-property custom 'find) custom tag))
|
|
|
882
|
|
|
883 (defun custom-travel-path (custom path)
|
|
|
884 "Find decedent of CUSTOM by looking through PATH."
|
|
|
885 (if (null path)
|
|
|
886 custom
|
|
|
887 (custom-travel-path (custom-find custom (car path)) (cdr path))))
|
|
|
888
|
|
|
889 (defun custom-field-extract (custom field)
|
|
|
890 "Extract CUSTOM's value in FIELD."
|
|
|
891 (if (stringp custom)
|
|
|
892 nil
|
|
|
893 (funcall (custom-property (custom-field-custom field) 'extract)
|
|
|
894 custom field)))
|
|
|
895
|
|
|
896 (defun custom-field-validate (custom field)
|
|
|
897 "Validate CUSTOM's value in FIELD.
|
|
|
898 Return nil if valid, otherwise return a cons-cell where the car is the
|
|
|
899 position of the error, and the cdr is a text describing the error."
|
|
|
900 (if (stringp custom)
|
|
|
901 nil
|
|
|
902 (funcall (custom-property custom 'validate) custom field)))
|
|
|
903
|
|
|
904 ;;; Field Functions:
|
|
|
905 ;;
|
|
|
906 ;; This section defines the public functions for manipulating the
|
|
|
907 ;; FIELD datatype. The FIELD instance hold information about a
|
|
|
908 ;; specific editing field in the customization buffer.
|
|
|
909 ;;
|
|
14032
|
910 ;; Each FIELD can be seen as an instantiation of a CUSTOM.
|
|
13401
|
911
|
|
|
912 (defvar custom-field-last nil)
|
|
|
913 ;; Last field containing point.
|
|
|
914 (make-variable-buffer-local 'custom-field-last)
|
|
|
915
|
|
|
916 (defvar custom-modified-list nil)
|
|
|
917 ;; List of modified fields.
|
|
|
918 (make-variable-buffer-local 'custom-modified-list)
|
|
|
919
|
|
|
920 (defun custom-field-create (custom value)
|
|
|
921 "Create a field structure of type CUSTOM containing VALUE.
|
|
|
922
|
|
|
923 A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
|
|
|
924 CUSTOM defines the type of the field,
|
|
|
925 VALUE is the current value of the field,
|
|
|
926 ORIGINAL is the original value when created, and
|
|
|
927 START and END are markers to the start and end of the field."
|
|
|
928 (vector custom value custom-nil nil nil))
|
|
|
929
|
|
|
930 (defun custom-field-custom (field)
|
|
|
931 "Return the `custom' attribute of FIELD."
|
|
|
932 (aref field 0))
|
|
|
933
|
|
|
934 (defun custom-field-value (field)
|
|
|
935 "Return the `value' attribute of FIELD."
|
|
|
936 (aref field 1))
|
|
|
937
|
|
|
938 (defun custom-field-original (field)
|
|
|
939 "Return the `original' attribute of FIELD."
|
|
|
940 (aref field 2))
|
|
|
941
|
|
|
942 (defun custom-field-start (field)
|
|
|
943 "Return the `start' attribute of FIELD."
|
|
|
944 (aref field 3))
|
|
|
945
|
|
|
946 (defun custom-field-end (field)
|
|
|
947 "Return the `end' attribute of FIELD."
|
|
|
948 (aref field 4))
|
|
|
949
|
|
|
950 (defun custom-field-value-set (field value)
|
|
|
951 "Set the `value' attribute of FIELD to VALUE."
|
|
|
952 (aset field 1 value))
|
|
|
953
|
|
|
954 (defun custom-field-original-set (field original)
|
|
|
955 "Set the `original' attribute of FIELD to ORIGINAL."
|
|
|
956 (aset field 2 original))
|
|
|
957
|
|
|
958 (defun custom-field-move (field start end)
|
|
|
959 "Set the `start'and `end' attributes of FIELD to START and END."
|
|
|
960 (set-marker (or (aref field 3) (aset field 3 (make-marker))) start)
|
|
|
961 (set-marker (or (aref field 4) (aset field 4 (make-marker))) end))
|
|
|
962
|
|
|
963 (defun custom-field-query (field)
|
|
|
964 "Query user for content of current field."
|
|
|
965 (funcall (custom-property (custom-field-custom field) 'query) field))
|
|
|
966
|
|
|
967 (defun custom-field-accept (field value &optional original)
|
|
|
968 "Store a new value into field FIELD, taking it from VALUE.
|
|
14032
|
969 If optional ORIGINAL is non-nil, consider VALUE for the original value."
|
|
13401
|
970 (let ((inhibit-point-motion-hooks t))
|
|
|
971 (funcall (custom-property (custom-field-custom field) 'accept)
|
|
|
972 field value original)))
|
|
|
973
|
|
|
974 (defun custom-field-face (field)
|
|
|
975 "The face used for highlighting FIELD."
|
|
|
976 (let ((custom (custom-field-custom field)))
|
|
|
977 (if (stringp custom)
|
|
|
978 nil
|
|
|
979 (let ((face (funcall (custom-property custom 'face) field)))
|
|
|
980 (if (custom-facep face) face nil)))))
|
|
|
981
|
|
|
982 (defun custom-field-update (field)
|
|
|
983 "Update the screen appearance of FIELD to correspond with the field's value."
|
|
|
984 (let ((custom (custom-field-custom field)))
|
|
|
985 (if (stringp custom)
|
|
|
986 nil
|
|
|
987 (funcall (custom-property custom 'update) field))))
|
|
|
988
|
|
|
989 ;;; Types:
|
|
|
990 ;;
|
|
|
991 ;; The following functions defines type specific actions.
|
|
|
992
|
|
|
993 (defun custom-repeat-eval (custom value)
|
|
|
994 "Non-nil if CUSTOM's VALUE needs to be evaluated."
|
|
|
995 (if (eq value custom-nil)
|
|
|
996 nil
|
|
|
997 (let ((child (custom-data custom))
|
|
|
998 (found nil))
|
|
|
999 (mapcar (lambda (v) (if (custom-eval child v) (setq found t)))
|
|
|
1000 value))))
|
|
|
1001
|
|
|
1002 (defun custom-repeat-quote (custom value)
|
|
|
1003 "A list of CUSTOM's VALUEs quoted."
|
|
|
1004 (let ((child (custom-data custom)))
|
|
|
1005 (apply 'append (mapcar (lambda (v) (custom-quote child v))
|
|
|
1006 value))))
|
|
|
1007
|
|
|
1008
|
|
|
1009 (defun custom-repeat-import (custom value)
|
|
|
1010 "Modify CUSTOM's VALUE to match internal expectations."
|
|
|
1011 (let ((child (custom-data custom)))
|
|
|
1012 (apply 'append (mapcar (lambda (v) (custom-import child v))
|
|
|
1013 value))))
|
|
|
1014
|
|
|
1015 (defun custom-repeat-accept (field value &optional original)
|
|
|
1016 "Store a new value into field FIELD, taking it from VALUE."
|
|
|
1017 (let ((values (copy-sequence (custom-field-value field)))
|
|
|
1018 (all (custom-field-value field))
|
|
|
1019 (start (custom-field-start field))
|
|
|
1020 current new)
|
|
|
1021 (if original
|
|
|
1022 (custom-field-original-set field value))
|
|
|
1023 (while (consp value)
|
|
|
1024 (setq new (car value)
|
|
|
1025 value (cdr value))
|
|
|
1026 (if values
|
|
|
1027 ;; Change existing field.
|
|
|
1028 (setq current (car values)
|
|
|
1029 values (cdr values))
|
|
|
1030 ;; Insert new field if series has grown.
|
|
|
1031 (goto-char start)
|
|
|
1032 (setq current (custom-repeat-insert-entry field))
|
|
|
1033 (setq all (custom-insert-before all nil current))
|
|
|
1034 (custom-field-value-set field all))
|
|
|
1035 (custom-field-accept current new original))
|
|
|
1036 (while (consp values)
|
|
|
1037 ;; Delete old field if series has scrunk.
|
|
|
1038 (setq current (car values)
|
|
|
1039 values (cdr values))
|
|
|
1040 (let ((pos (custom-field-start current))
|
|
|
1041 data)
|
|
|
1042 (while (not data)
|
|
|
1043 (setq pos (previous-single-property-change pos 'custom-data))
|
|
|
1044 (custom-assert 'pos)
|
|
|
1045 (setq data (get-text-property pos 'custom-data))
|
|
|
1046 (or (and (arrayp data)
|
|
|
1047 (> (length data) 1)
|
|
|
1048 (eq current (aref data 1)))
|
|
|
1049 (setq data nil)))
|
|
|
1050 (custom-repeat-delete data)))))
|
|
|
1051
|
|
|
1052 (defun custom-repeat-insert (custom level)
|
|
|
1053 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
|
|
|
1054 (let* ((field (custom-field-create custom nil))
|
|
|
1055 (add-tag (custom-property custom 'add-tag))
|
|
|
1056 (start (make-marker))
|
|
|
1057 (data (vector field nil start nil)))
|
|
|
1058 (custom-text-insert "\n")
|
|
|
1059 (let ((pos (point)))
|
|
|
1060 (custom-text-insert (custom-property custom 'prefix))
|
|
|
1061 (custom-tag-insert add-tag 'custom-repeat-add data)
|
|
|
1062 (set-marker start pos))
|
|
|
1063 (custom-field-move field start (point))
|
|
|
1064 (custom-documentation-insert custom)
|
|
|
1065 field))
|
|
|
1066
|
|
|
1067 (defun custom-repeat-insert-entry (repeat)
|
|
|
1068 "Insert entry at point in the REPEAT field."
|
|
|
1069 (let* ((inhibit-point-motion-hooks t)
|
|
|
1070 (inhibit-read-only t)
|
|
|
1071 (before-change-functions nil)
|
|
|
1072 (after-change-functions nil)
|
|
|
1073 (custom (custom-field-custom repeat))
|
|
|
1074 (add-tag (custom-property custom 'add-tag))
|
|
|
1075 (del-tag (custom-property custom 'del-tag))
|
|
|
1076 (start (make-marker))
|
|
|
1077 (end (make-marker))
|
|
|
1078 (data (vector repeat nil start end))
|
|
|
1079 field)
|
|
|
1080 (insert-before-markers "\n")
|
|
|
1081 (backward-char 1)
|
|
|
1082 (set-marker start (point))
|
|
|
1083 (custom-text-insert " ")
|
|
|
1084 (aset data 1 (setq field (custom-insert (custom-data custom) nil)))
|
|
|
1085 (custom-text-insert " ")
|
|
|
1086 (set-marker end (point))
|
|
|
1087 (goto-char start)
|
|
|
1088 (custom-text-insert (custom-property custom 'prefix))
|
|
|
1089 (custom-tag-insert add-tag 'custom-repeat-add data)
|
|
|
1090 (custom-text-insert " ")
|
|
|
1091 (custom-tag-insert del-tag 'custom-repeat-delete data)
|
|
|
1092 (forward-char 1)
|
|
|
1093 field))
|
|
|
1094
|
|
|
1095 (defun custom-repeat-add (data)
|
|
|
1096 "Add list entry."
|
|
|
1097 (let ((parent (aref data 0))
|
|
|
1098 (field (aref data 1))
|
|
|
1099 (at (aref data 2))
|
|
|
1100 new)
|
|
|
1101 (goto-char at)
|
|
|
1102 (setq new (custom-repeat-insert-entry parent))
|
|
|
1103 (custom-field-value-set parent
|
|
|
1104 (custom-insert-before (custom-field-value parent)
|
|
|
1105 field new))))
|
|
|
1106
|
|
|
1107 (defun custom-repeat-delete (data)
|
|
|
1108 "Delete list entry."
|
|
|
1109 (let ((inhibit-point-motion-hooks t)
|
|
|
1110 (inhibit-read-only t)
|
|
|
1111 (before-change-functions nil)
|
|
|
1112 (after-change-functions nil)
|
|
|
1113 (parent (aref data 0))
|
|
|
1114 (field (aref data 1)))
|
|
|
1115 (delete-region (aref data 2) (1+ (aref data 3)))
|
|
|
1116 (custom-field-untouch (aref data 1))
|
|
|
1117 (custom-field-value-set parent
|
|
|
1118 (delq field (custom-field-value parent)))))
|
|
|
1119
|
|
|
1120 (defun custom-repeat-match (custom values)
|
|
|
1121 "Match CUSTOM with VALUES."
|
|
|
1122 (let* ((child (custom-data custom))
|
|
|
1123 (match (custom-match child values))
|
|
|
1124 matches)
|
|
|
1125 (while (not (eq (car match) custom-nil))
|
|
|
1126 (setq matches (cons (car match) matches)
|
|
|
1127 values (cdr match)
|
|
|
1128 match (custom-match child values)))
|
|
|
1129 (cons (nreverse matches) values)))
|
|
|
1130
|
|
|
1131 (defun custom-repeat-extract (custom field)
|
|
14032
|
1132 "Extract list of children's values."
|
|
13401
|
1133 (let ((values (custom-field-value field))
|
|
|
1134 (data (custom-data custom))
|
|
|
1135 result)
|
|
|
1136 (if (eq values custom-nil)
|
|
|
1137 ()
|
|
|
1138 (while values
|
|
|
1139 (setq result (append result (custom-field-extract data (car values)))
|
|
|
1140 values (cdr values))))
|
|
|
1141 result))
|
|
|
1142
|
|
|
1143 (defun custom-repeat-validate (custom field)
|
|
|
1144 "Validate children."
|
|
|
1145 (let ((values (custom-field-value field))
|
|
|
1146 (data (custom-data custom))
|
|
|
1147 result)
|
|
|
1148 (if (eq values custom-nil)
|
|
|
1149 (setq result (cons (custom-field-start field) "Uninitialized list")))
|
|
|
1150 (while (and values (not result))
|
|
|
1151 (setq result (custom-field-validate data (car values))
|
|
|
1152 values (cdr values)))
|
|
|
1153 result))
|
|
|
1154
|
|
|
1155 (defun custom-pair-accept (field value &optional original)
|
|
|
1156 "Store a new value into field FIELD, taking it from VALUE."
|
|
|
1157 (custom-group-accept field (list (car value) (cdr value)) original))
|
|
|
1158
|
|
|
1159 (defun custom-pair-eval (custom value)
|
|
|
1160 "Non-nil if CUSTOM's VALUE needs to be evaluated."
|
|
|
1161 (custom-group-eval custom (list (car value) (cdr value))))
|
|
|
1162
|
|
|
1163 (defun custom-pair-import (custom value)
|
|
|
1164 "Modify CUSTOM's VALUE to match internal expectations."
|
|
|
1165 (let ((result (car (custom-group-import custom
|
|
|
1166 (list (car value) (cdr value))))))
|
|
|
1167 (custom-assert '(eq (length result) 2))
|
|
|
1168 (list (cons (nth 0 result) (nth 1 result)))))
|
|
|
1169
|
|
|
1170 (defun custom-pair-quote (custom value)
|
|
|
1171 "Quote CUSTOM's VALUE if necessary."
|
|
|
1172 (if (custom-eval custom value)
|
|
|
1173 (let ((v (car (custom-group-quote custom
|
|
|
1174 (list (car value) (cdr value))))))
|
|
|
1175 (list (list 'cons (nth 0 v) (nth 1 v))))
|
|
|
1176 (custom-default-quote custom value)))
|
|
|
1177
|
|
|
1178 (defun custom-pair-extract (custom field)
|
|
14032
|
1179 "Extract cons of children's values."
|
|
13401
|
1180 (let ((values (custom-field-value field))
|
|
|
1181 (data (custom-data custom))
|
|
|
1182 result)
|
|
|
1183 (custom-assert '(eq (length values) (length data)))
|
|
|
1184 (while values
|
|
|
1185 (setq result (append result
|
|
|
1186 (custom-field-extract (car data) (car values)))
|
|
|
1187 data (cdr data)
|
|
|
1188 values (cdr values)))
|
|
|
1189 (custom-assert '(null data))
|
|
|
1190 (list (cons (nth 0 result) (nth 1 result)))))
|
|
|
1191
|
|
|
1192 (defun custom-list-quote (custom value)
|
|
|
1193 "Quote CUSTOM's VALUE if necessary."
|
|
|
1194 (if (custom-eval custom value)
|
|
|
1195 (let ((v (car (custom-group-quote custom value))))
|
|
|
1196 (list (cons 'list v)))
|
|
|
1197 (custom-default-quote custom value)))
|
|
|
1198
|
|
|
1199 (defun custom-list-extract (custom field)
|
|
14032
|
1200 "Extract list of children's values."
|
|
13401
|
1201 (let ((values (custom-field-value field))
|
|
|
1202 (data (custom-data custom))
|
|
|
1203 result)
|
|
|
1204 (custom-assert '(eq (length values) (length data)))
|
|
|
1205 (while values
|
|
|
1206 (setq result (append result
|
|
|
1207 (custom-field-extract (car data) (car values)))
|
|
|
1208 data (cdr data)
|
|
|
1209 values (cdr values)))
|
|
|
1210 (custom-assert '(null data))
|
|
|
1211 (list result)))
|
|
|
1212
|
|
|
1213 (defun custom-group-validate (custom field)
|
|
|
1214 "Validate children."
|
|
|
1215 (let ((values (custom-field-value field))
|
|
|
1216 (data (custom-data custom))
|
|
|
1217 result)
|
|
|
1218 (if (eq values custom-nil)
|
|
|
1219 (setq result (cons (custom-field-start field) "Uninitialized list"))
|
|
|
1220 (custom-assert '(eq (length values) (length data))))
|
|
|
1221 (while (and values (not result))
|
|
|
1222 (setq result (custom-field-validate (car data) (car values))
|
|
|
1223 data (cdr data)
|
|
|
1224 values (cdr values)))
|
|
|
1225 result))
|
|
|
1226
|
|
|
1227 (defun custom-group-eval (custom value)
|
|
|
1228 "Non-nil if CUSTOM's VALUE needs to be evaluated."
|
|
|
1229 (let ((found nil))
|
|
|
1230 (mapcar (lambda (c)
|
|
|
1231 (or (stringp c)
|
|
|
1232 (let ((match (custom-match c value)))
|
|
|
1233 (if (custom-eval c (car match))
|
|
|
1234 (setq found t))
|
|
|
1235 (setq value (cdr match)))))
|
|
|
1236 (custom-data custom))
|
|
|
1237 found))
|
|
|
1238
|
|
|
1239 (defun custom-group-quote (custom value)
|
|
|
1240 "A list of CUSTOM's VALUE members, quoted."
|
|
|
1241 (list (apply 'append
|
|
|
1242 (mapcar (lambda (c)
|
|
|
1243 (if (stringp c)
|
|
|
1244 ()
|
|
|
1245 (let ((match (custom-match c value)))
|
|
|
1246 (prog1 (custom-quote c (car match))
|
|
|
1247 (setq value (cdr match))))))
|
|
|
1248 (custom-data custom)))))
|
|
|
1249
|
|
|
1250 (defun custom-group-import (custom value)
|
|
|
1251 "Modify CUSTOM's VALUE to match internal expectations."
|
|
|
1252 (list (apply 'append
|
|
|
1253 (mapcar (lambda (c)
|
|
|
1254 (if (stringp c)
|
|
|
1255 ()
|
|
|
1256 (let ((match (custom-match c value)))
|
|
|
1257 (prog1 (custom-import c (car match))
|
|
|
1258 (setq value (cdr match))))))
|
|
|
1259 (custom-data custom)))))
|
|
|
1260
|
|
|
1261 (defun custom-group-initialize (custom)
|
|
|
1262 "Initialize `doc' and `default' entries in CUSTOM."
|
|
|
1263 (if (custom-name custom)
|
|
|
1264 (custom-default-initialize custom)
|
|
|
1265 (mapcar 'custom-initialize (custom-data custom))))
|
|
|
1266
|
|
|
1267 (defun custom-group-apply (field)
|
|
|
1268 "Reset `value' in FIELD to `original'."
|
|
|
1269 (let ((custom (custom-field-custom field))
|
|
|
1270 (values (custom-field-value field)))
|
|
|
1271 (if (custom-name custom)
|
|
|
1272 (custom-default-apply field)
|
|
|
1273 (mapcar 'custom-field-apply values))))
|
|
|
1274
|
|
|
1275 (defun custom-group-reset (field)
|
|
|
1276 "Reset `value' in FIELD to `original'."
|
|
|
1277 (let ((custom (custom-field-custom field))
|
|
|
1278 (values (custom-field-value field)))
|
|
|
1279 (if (custom-name custom)
|
|
|
1280 (custom-default-reset field)
|
|
|
1281 (mapcar 'custom-field-reset values))))
|
|
|
1282
|
|
|
1283 (defun custom-group-factory-reset (field)
|
|
|
1284 "Reset `value' in FIELD to `default'."
|
|
|
1285 (let ((custom (custom-field-custom field))
|
|
|
1286 (values (custom-field-value field)))
|
|
|
1287 (if (custom-name custom)
|
|
|
1288 (custom-default-factory-reset field)
|
|
|
1289 (mapcar 'custom-field-factory-reset values))))
|
|
|
1290
|
|
|
1291 (defun custom-group-find (custom tag)
|
|
|
1292 "Find child in CUSTOM with `tag' TAG."
|
|
|
1293 (let ((data (custom-data custom))
|
|
|
1294 (result nil))
|
|
|
1295 (while (not result)
|
|
|
1296 (custom-assert 'data)
|
|
|
1297 (if (equal (custom-tag (car data)) tag)
|
|
|
1298 (setq result (car data))
|
|
|
1299 (setq data (cdr data))))))
|
|
|
1300
|
|
|
1301 (defun custom-group-accept (field value &optional original)
|
|
|
1302 "Store a new value into field FIELD, taking it from VALUE."
|
|
|
1303 (let* ((values (custom-field-value field))
|
|
|
1304 (custom (custom-field-custom field))
|
|
|
1305 (from (custom-field-start field))
|
|
|
1306 (face-tag (custom-face-tag custom))
|
|
|
1307 current)
|
|
|
1308 (if face-tag
|
|
|
1309 (put-text-property from (+ from (length (custom-tag custom)))
|
|
|
1310 'face (funcall face-tag field value)))
|
|
|
1311 (if original
|
|
|
1312 (custom-field-original-set field value))
|
|
|
1313 (while values
|
|
|
1314 (setq current (car values)
|
|
|
1315 values (cdr values))
|
|
|
1316 (if current
|
|
|
1317 (let* ((custom (custom-field-custom current))
|
|
|
1318 (match (custom-match custom value)))
|
|
|
1319 (setq value (cdr match))
|
|
|
1320 (custom-field-accept current (car match) original))))))
|
|
|
1321
|
|
|
1322 (defun custom-group-insert (custom level)
|
|
|
1323 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
|
|
|
1324 (let* ((field (custom-field-create custom nil))
|
|
|
1325 fields hidden
|
|
|
1326 (from (point))
|
|
|
1327 (compact (custom-compact custom))
|
|
|
1328 (tag (custom-tag custom))
|
|
|
1329 (face-tag (custom-face-tag custom)))
|
|
|
1330 (cond (face-tag (custom-text-insert tag))
|
|
|
1331 (tag (custom-tag-insert tag field)))
|
|
|
1332 (or compact (custom-documentation-insert custom))
|
|
|
1333 (or compact (custom-text-insert "\n"))
|
|
|
1334 (let ((data (custom-data custom)))
|
|
|
1335 (while data
|
|
|
1336 (setq fields (cons (custom-insert (car data) (if level (1+ level)))
|
|
|
1337 fields))
|
|
|
1338 (setq hidden (or (stringp (car data))
|
|
|
1339 (custom-property (car data) 'hidden)))
|
|
|
1340 (setq data (cdr data))
|
|
|
1341 (if data (custom-text-insert (cond (hidden "")
|
|
|
1342 (compact " ")
|
|
|
1343 (t "\n"))))))
|
|
|
1344 (if compact (custom-documentation-insert custom))
|
|
|
1345 (custom-field-value-set field (nreverse fields))
|
|
|
1346 (custom-field-move field from (point))
|
|
|
1347 field))
|
|
|
1348
|
|
|
1349 (defun custom-choice-insert (custom level)
|
|
|
1350 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
|
|
|
1351 (let* ((field (custom-field-create custom nil))
|
|
|
1352 (from (point)))
|
|
|
1353 (custom-text-insert "lars er en nisse")
|
|
|
1354 (custom-field-move field from (point))
|
|
|
1355 (custom-documentation-insert custom)
|
|
|
1356 (custom-field-reset field)
|
|
|
1357 field))
|
|
|
1358
|
|
|
1359 (defun custom-choice-accept (field value &optional original)
|
|
|
1360 "Store a new value into field FIELD, taking it from VALUE."
|
|
|
1361 (let ((custom (custom-field-custom field))
|
|
|
1362 (start (custom-field-start field))
|
|
|
1363 (end (custom-field-end field))
|
|
|
1364 (inhibit-read-only t)
|
|
|
1365 (before-change-functions nil)
|
|
|
1366 (after-change-functions nil)
|
|
|
1367 from)
|
|
|
1368 (cond (original
|
|
|
1369 (setq custom-modified-list (delq field custom-modified-list))
|
|
|
1370 (custom-field-original-set field value))
|
|
|
1371 ((equal value (custom-field-original field))
|
|
|
1372 (setq custom-modified-list (delq field custom-modified-list)))
|
|
|
1373 (t
|
|
|
1374 (add-to-list 'custom-modified-list field)))
|
|
|
1375 (custom-field-untouch (custom-field-value field))
|
|
|
1376 (delete-region start end)
|
|
|
1377 (goto-char start)
|
|
|
1378 (setq from (point))
|
|
|
1379 (insert-before-markers " ")
|
|
|
1380 (backward-char 1)
|
|
|
1381 (custom-category-set (point) (1+ (point)) 'custom-hidden-properties)
|
|
|
1382 (custom-tag-insert (custom-tag custom) field)
|
|
|
1383 (custom-text-insert ": ")
|
|
|
1384 (let ((data (custom-data custom))
|
|
|
1385 found begin)
|
|
|
1386 (while (and data (not found))
|
|
|
1387 (if (not (custom-valid (car data) value))
|
|
|
1388 (setq data (cdr data))
|
|
|
1389 (setq found (custom-insert (car data) nil))
|
|
|
1390 (setq data nil)))
|
|
|
1391 (if found
|
|
|
1392 ()
|
|
|
1393 (setq begin (point)
|
|
|
1394 found (custom-insert (custom-property custom 'none) nil))
|
|
|
1395 (add-text-properties begin (point)
|
|
|
1396 (list rear-nonsticky t
|
|
|
1397 'face custom-field-uninitialized-face)))
|
|
|
1398 (or original
|
|
|
1399 (custom-field-original-set found (custom-field-original field)))
|
|
|
1400 (custom-field-accept found value original)
|
|
|
1401 (custom-field-value-set field found)
|
|
|
1402 (custom-field-move field from end))))
|
|
|
1403
|
|
|
1404 (defun custom-choice-extract (custom field)
|
|
14032
|
1405 "Extract child's value."
|
|
13401
|
1406 (let ((value (custom-field-value field)))
|
|
|
1407 (custom-field-extract (custom-field-custom value) value)))
|
|
|
1408
|
|
|
1409 (defun custom-choice-validate (custom field)
|
|
14032
|
1410 "Validate child's value."
|
|
13401
|
1411 (let ((value (custom-field-value field))
|
|
|
1412 (custom (custom-field-custom field)))
|
|
|
1413 (if (or (eq value custom-nil)
|
|
|
1414 (eq (custom-field-custom value) (custom-property custom 'none)))
|
|
|
1415 (cons (custom-field-start field) "Make a choice")
|
|
|
1416 (custom-field-validate (custom-field-custom value) value))))
|
|
|
1417
|
|
|
1418 (defun custom-choice-query (field)
|
|
|
1419 "Choose a child."
|
|
|
1420 (let* ((custom (custom-field-custom field))
|
|
|
1421 (old (custom-field-custom (custom-field-value field)))
|
|
|
1422 (default (custom-prompt old))
|
|
|
1423 (tag (custom-prompt custom))
|
|
|
1424 (data (custom-data custom))
|
|
|
1425 current alist)
|
|
|
1426 (if (eq (length data) 2)
|
|
|
1427 (custom-field-accept field (custom-default (if (eq (nth 0 data) old)
|
|
|
1428 (nth 1 data)
|
|
|
1429 (nth 0 data))))
|
|
|
1430 (while data
|
|
|
1431 (setq current (car data)
|
|
|
1432 data (cdr data))
|
|
|
1433 (setq alist (cons (cons (custom-prompt current) current) alist)))
|
|
|
1434 (let ((answer (cond ((and (fboundp 'button-press-event-p)
|
|
|
1435 (fboundp 'popup-menu)
|
|
|
1436 (button-press-event-p last-input-event))
|
|
|
1437 (cdr (assoc (car (custom-x-really-popup-menu
|
|
|
1438 last-input-event tag
|
|
|
1439 (reverse alist)))
|
|
|
1440 alist)))
|
|
|
1441 ((listp last-input-event)
|
|
|
1442 (x-popup-menu last-input-event
|
|
|
1443 (list tag (cons "" (reverse alist)))))
|
|
|
1444 (t
|
|
|
1445 (let ((choice (completing-read (concat tag
|
|
|
1446 " (default "
|
|
|
1447 default
|
|
|
1448 "): ")
|
|
|
1449 alist nil t)))
|
|
|
1450 (if (or (null choice) (string-equal choice ""))
|
|
|
1451 (setq choice default))
|
|
|
1452 (cdr (assoc choice alist)))))))
|
|
|
1453 (if answer
|
|
|
1454 (custom-field-accept field (custom-default answer)))))))
|
|
|
1455
|
|
|
1456 (defun custom-file-query (field)
|
|
|
1457 "Prompt for a file name"
|
|
|
1458 (let* ((value (custom-field-value field))
|
|
|
1459 (custom (custom-field-custom field))
|
|
|
1460 (valid (custom-valid custom value))
|
|
|
1461 (directory (custom-property custom 'directory))
|
|
|
1462 (default (and (not valid)
|
|
|
1463 (custom-property custom 'default-file)))
|
|
|
1464 (tag (custom-tag custom))
|
|
|
1465 (prompt (if default
|
|
|
1466 (concat tag " (" default "): ")
|
|
|
1467 (concat tag ": "))))
|
|
|
1468 (custom-field-accept field
|
|
|
1469 (if (custom-valid custom value)
|
|
|
1470 (read-file-name prompt
|
|
|
1471 (if (file-name-absolute-p value)
|
|
|
1472 ""
|
|
|
1473 directory)
|
|
|
1474 default nil value)
|
|
|
1475 (read-file-name prompt directory default)))))
|
|
|
1476
|
|
|
1477 (defun custom-face-eval (custom value)
|
|
|
1478 "Return non-nil if CUSTOM's VALUE needs to be evaluated."
|
|
|
1479 (not (symbolp value)))
|
|
|
1480
|
|
|
1481 (defun custom-face-import (custom value)
|
|
|
1482 "Modify CUSTOM's VALUE to match internal expectations."
|
|
|
1483 (let ((name (symbol-name value)))
|
|
|
1484 (list (if (string-match "\
|
|
|
1485 custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
|
|
|
1486 name)
|
|
|
1487 (list 'custom-face-lookup
|
|
|
1488 (match-string 1 name)
|
|
|
1489 (match-string 2 name)
|
|
|
1490 (match-string 3 name)
|
|
|
1491 (intern (match-string 4 name))
|
|
|
1492 (intern (match-string 5 name))
|
|
|
1493 (intern (match-string 6 name)))
|
|
|
1494 value))))
|
|
|
1495
|
|
|
1496 (defun custom-face-lookup (fg bg stipple bold italic underline)
|
|
|
1497 "Lookup or create a face with specified attributes.
|
|
|
1498 FG BG STIPPLE BOLD ITALIC UNDERLINE"
|
|
|
1499 (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
|
|
|
1500 (or fg "default")
|
|
|
1501 (or bg "default")
|
|
|
1502 (or stipple "default")
|
|
|
1503 bold italic underline))))
|
|
|
1504 (if (and (custom-facep name)
|
|
|
1505 (fboundp 'make-face))
|
|
|
1506 ()
|
|
|
1507 (make-face name)
|
|
|
1508 (modify-face name
|
|
|
1509 (if (string-equal fg "default") nil fg)
|
|
|
1510 (if (string-equal bg "default") nil bg)
|
|
|
1511 (if (string-equal stipple "default") nil stipple)
|
|
|
1512 bold italic underline))
|
|
|
1513 name))
|
|
|
1514
|
|
|
1515 (defun custom-face-hack (field value)
|
|
|
1516 "Face that should be used for highlighting FIELD containing VALUE."
|
|
|
1517 (let* ((custom (custom-field-custom field))
|
|
14841
|
1518 (form (funcall (custom-property custom 'export) custom value))
|
|
|
1519 (face (apply (car form) (cdr form))))
|
|
13401
|
1520 (if (custom-facep face) face nil)))
|
|
|
1521
|
|
|
1522 (defun custom-const-insert (custom level)
|
|
|
1523 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
|
|
|
1524 (let* ((field (custom-field-create custom custom-nil))
|
|
|
1525 (face (custom-field-face field))
|
|
|
1526 (from (point)))
|
|
|
1527 (custom-text-insert (custom-tag custom))
|
|
|
1528 (add-text-properties from (point)
|
|
|
1529 (list 'face face
|
|
|
1530 rear-nonsticky t))
|
|
|
1531 (custom-documentation-insert custom)
|
|
|
1532 (custom-field-move field from (point))
|
|
|
1533 field))
|
|
|
1534
|
|
|
1535 (defun custom-const-update (field)
|
|
|
1536 "Update face of FIELD."
|
|
|
1537 (let ((from (custom-field-start field))
|
|
|
1538 (custom (custom-field-custom field)))
|
|
|
1539 (put-text-property from (+ from (length (custom-tag custom)))
|
|
|
1540 'face (custom-field-face field))))
|
|
|
1541
|
|
|
1542 (defun custom-const-valid (custom value)
|
|
|
1543 "Non-nil if CUSTOM can validly have the value VALUE."
|
|
|
1544 (equal (custom-default custom) value))
|
|
|
1545
|
|
|
1546 (defun custom-const-face (field)
|
|
|
1547 "Face used for a FIELD."
|
|
|
1548 (custom-default (custom-field-custom field)))
|
|
|
1549
|
|
|
1550 (defun custom-sexp-read (custom string)
|
|
|
1551 "Read from CUSTOM an STRING."
|
|
|
1552 (save-match-data
|
|
|
1553 (save-excursion
|
|
|
1554 (set-buffer (get-buffer-create " *Custom Scratch*"))
|
|
|
1555 (erase-buffer)
|
|
|
1556 (insert string)
|
|
|
1557 (goto-char (point-min))
|
|
|
1558 (prog1 (read (current-buffer))
|
|
|
1559 (or (looking-at
|
|
|
1560 (concat (regexp-quote (char-to-string
|
|
|
1561 (custom-padding custom)))
|
|
|
1562 "*\\'"))
|
|
|
1563 (error "Junk at end of expression"))))))
|
|
|
1564
|
|
|
1565 (autoload 'pp-to-string "pp")
|
|
|
1566
|
|
|
1567 (defun custom-sexp-write (custom sexp)
|
|
|
1568 "Write CUSTOM SEXP as string."
|
|
|
1569 (let ((string (prin1-to-string sexp)))
|
|
|
1570 (if (<= (length string) (custom-width custom))
|
|
|
1571 string
|
|
|
1572 (setq string (pp-to-string sexp))
|
|
|
1573 (string-match "[ \t\n]*\\'" string)
|
|
|
1574 (concat "\n" (substring string 0 (match-beginning 0))))))
|
|
|
1575
|
|
|
1576 (defun custom-string-read (custom string)
|
|
|
1577 "Read string by ignoring trailing padding characters."
|
|
|
1578 (let ((last (length string))
|
|
|
1579 (padding (custom-padding custom)))
|
|
|
1580 (while (and (> last 0)
|
|
|
1581 (eq (aref string (1- last)) padding))
|
|
|
1582 (setq last (1- last)))
|
|
|
1583 (substring string 0 last)))
|
|
|
1584
|
|
|
1585 (defun custom-string-write (custom string)
|
|
|
1586 "Write raw string."
|
|
|
1587 string)
|
|
|
1588
|
|
|
1589 (defun custom-button-insert (custom level)
|
|
|
1590 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
|
|
|
1591 (custom-tag-insert (concat "[" (custom-tag custom) "]")
|
|
|
1592 (custom-property custom 'query))
|
|
|
1593 (custom-documentation-insert custom)
|
|
|
1594 nil)
|
|
|
1595
|
|
|
1596 (defun custom-default-export (custom value)
|
|
|
1597 ;; Convert CUSTOM's VALUE to external representation.
|
|
|
1598 ;; See `custom-import'.
|
|
|
1599 (if (custom-eval custom value)
|
|
|
1600 (eval (car (custom-quote custom value)))
|
|
|
1601 value))
|
|
|
1602
|
|
|
1603 (defun custom-default-quote (custom value)
|
|
|
1604 "Quote CUSTOM's VALUE if necessary."
|
|
|
1605 (list (if (and (not (custom-eval custom value))
|
|
|
1606 (or (and (symbolp value)
|
|
|
1607 value
|
|
|
1608 (not (eq t value)))
|
|
|
1609 (and (listp value)
|
|
|
1610 value
|
|
|
1611 (not (memq (car value) '(quote function lambda))))))
|
|
|
1612 (list 'quote value)
|
|
|
1613 value)))
|
|
|
1614
|
|
|
1615 (defun custom-default-initialize (custom)
|
|
|
1616 "Initialize `doc' and `default' entries in CUSTOM."
|
|
|
1617 (let ((name (custom-name custom)))
|
|
|
1618 (if (null name)
|
|
|
1619 ()
|
|
|
1620 (let ((default (custom-default custom))
|
|
|
1621 (doc (custom-documentation custom))
|
|
|
1622 (vdoc (documentation-property name 'variable-documentation t)))
|
|
|
1623 (if doc
|
|
|
1624 (or vdoc (put name 'variable-documentation doc))
|
|
|
1625 (if vdoc (custom-property-set custom 'doc vdoc)))
|
|
|
1626 (if (eq default custom-nil)
|
|
|
1627 (if (boundp name)
|
|
|
1628 (custom-property-set custom 'default (symbol-value name)))
|
|
|
1629 (or (boundp name)
|
|
|
1630 (set name default)))))))
|
|
|
1631
|
|
|
1632 (defun custom-default-insert (custom level)
|
|
|
1633 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
|
|
|
1634 (let ((field (custom-field-create custom custom-nil))
|
|
|
1635 (tag (custom-tag custom)))
|
|
|
1636 (if (null tag)
|
|
|
1637 ()
|
|
|
1638 (custom-tag-insert tag field)
|
|
|
1639 (custom-text-insert ": "))
|
|
|
1640 (custom-field-insert field)
|
|
|
1641 (custom-documentation-insert custom)
|
|
|
1642 field))
|
|
|
1643
|
|
|
1644 (defun custom-default-accept (field value &optional original)
|
|
|
1645 "Store a new value into field FIELD, taking it from VALUE."
|
|
|
1646 (if original
|
|
|
1647 (custom-field-original-set field value))
|
|
|
1648 (custom-field-value-set field value)
|
|
|
1649 (custom-field-update field))
|
|
|
1650
|
|
|
1651 (defun custom-default-apply (field)
|
|
|
1652 "Apply any changes in FIELD since the last apply."
|
|
|
1653 (let* ((custom (custom-field-custom field))
|
|
|
1654 (name (custom-name custom)))
|
|
|
1655 (if (null name)
|
|
|
1656 (error "This field cannot be applied alone"))
|
|
|
1657 (custom-external-set name (custom-name-value name))
|
|
|
1658 (custom-field-reset field)))
|
|
|
1659
|
|
|
1660 (defun custom-default-reset (field)
|
|
|
1661 "Reset content of editing FIELD to `original'."
|
|
|
1662 (custom-field-accept field (custom-field-original field) t))
|
|
|
1663
|
|
|
1664 (defun custom-default-factory-reset (field)
|
|
|
1665 "Reset content of editing FIELD to `default'."
|
|
|
1666 (let* ((custom (custom-field-custom field))
|
|
|
1667 (default (car (custom-import custom (custom-default custom)))))
|
|
|
1668 (or (eq default custom-nil)
|
|
|
1669 (custom-field-accept field default nil))))
|
|
|
1670
|
|
|
1671 (defun custom-default-query (field)
|
|
|
1672 "Prompt for a FIELD"
|
|
|
1673 (let* ((custom (custom-field-custom field))
|
|
|
1674 (value (custom-field-value field))
|
|
|
1675 (initial (custom-write custom value))
|
|
|
1676 (prompt (concat (custom-prompt custom) ": ")))
|
|
|
1677 (custom-field-accept field
|
|
|
1678 (custom-read custom
|
|
|
1679 (if (custom-valid custom value)
|
|
|
1680 (read-string prompt (cons initial 1))
|
|
|
1681 (read-string prompt))))))
|
|
|
1682
|
|
|
1683 (defun custom-default-match (custom values)
|
|
|
1684 "Match CUSTOM with VALUES."
|
|
|
1685 values)
|
|
|
1686
|
|
|
1687 (defun custom-default-extract (custom field)
|
|
|
1688 "Extract CUSTOM's content in FIELD."
|
|
|
1689 (list (custom-field-value field)))
|
|
|
1690
|
|
|
1691 (defun custom-default-validate (custom field)
|
|
|
1692 "Validate FIELD."
|
|
|
1693 (let ((value (custom-field-value field))
|
|
|
1694 (start (custom-field-start field)))
|
|
|
1695 (cond ((eq value custom-nil)
|
|
|
1696 (cons start "Uninitialized field"))
|
|
|
1697 ((and (consp value) (eq (car value) custom-invalid))
|
|
14032
|
1698 (cons start "Unparsable field content"))
|
|
13401
|
1699 ((custom-valid custom value)
|
|
|
1700 nil)
|
|
|
1701 (t
|
|
|
1702 (cons start "Wrong type of field content")))))
|
|
|
1703
|
|
|
1704 (defun custom-default-face (field)
|
|
|
1705 "Face used for a FIELD."
|
|
|
1706 (let ((value (custom-field-value field)))
|
|
|
1707 (cond ((eq value custom-nil)
|
|
|
1708 custom-field-uninitialized-face)
|
|
|
1709 ((not (custom-valid (custom-field-custom field) value))
|
|
|
1710 custom-field-invalid-face)
|
|
|
1711 ((not (equal (custom-field-original field) value))
|
|
|
1712 custom-field-modified-face)
|
|
|
1713 (t
|
|
|
1714 custom-field-face))))
|
|
|
1715
|
|
|
1716 (defun custom-default-update (field)
|
|
|
1717 "Update the content of FIELD."
|
|
|
1718 (let ((inhibit-point-motion-hooks t)
|
|
|
1719 (before-change-functions nil)
|
|
|
1720 (after-change-functions nil)
|
|
|
1721 (start (custom-field-start field))
|
|
|
1722 (end (custom-field-end field))
|
|
|
1723 (pos (point)))
|
|
|
1724 ;; Keep track of how many modified fields we have.
|
|
|
1725 (cond ((equal (custom-field-value field) (custom-field-original field))
|
|
|
1726 (setq custom-modified-list (delq field custom-modified-list)))
|
|
|
1727 ((memq field custom-modified-list))
|
|
|
1728 (t
|
|
|
1729 (setq custom-modified-list (cons field custom-modified-list))))
|
|
|
1730 ;; Update the field.
|
|
|
1731 (goto-char end)
|
|
|
1732 (insert-before-markers " ")
|
|
|
1733 (delete-region start (1- end))
|
|
|
1734 (goto-char start)
|
|
|
1735 (custom-field-insert field)
|
|
|
1736 (goto-char end)
|
|
|
1737 (delete-char 1)
|
|
|
1738 (goto-char pos)
|
|
|
1739 (and (<= start pos)
|
|
|
1740 (<= pos end)
|
|
|
1741 (custom-field-enter field))))
|
|
|
1742
|
|
|
1743 ;;; Create Buffer:
|
|
|
1744 ;;
|
|
|
1745 ;; Public functions to create a customization buffer and to insert
|
|
|
1746 ;; various forms of text, fields, and buttons in it.
|
|
|
1747
|
|
|
1748 (defun customize ()
|
|
|
1749 "Customize GNU Emacs.
|
|
|
1750 Create a *Customize* buffer with editable customization information
|
|
|
1751 about GNU Emacs."
|
|
|
1752 (interactive)
|
|
|
1753 (custom-buffer-create "*Customize*")
|
|
|
1754 (custom-reset-all))
|
|
|
1755
|
|
|
1756 (defun custom-buffer-create (name &optional custom types set get save)
|
|
|
1757 "Create a customization buffer named NAME.
|
|
|
1758 If the optional argument CUSTOM is non-nil, use that as the custom declaration.
|
|
|
1759 If the optional argument TYPES is non-nil, use that as the local types.
|
|
|
1760 If the optional argument SET is non-nil, use that to set external data.
|
|
|
1761 If the optional argument GET is non-nil, use that to get external data.
|
|
|
1762 If the optional argument SAVE is non-nil, use that for saving changes."
|
|
|
1763 (switch-to-buffer name)
|
|
|
1764 (buffer-disable-undo (current-buffer))
|
|
|
1765 (custom-mode)
|
|
|
1766 (setq custom-local-type-properties types)
|
|
|
1767 (if (null custom)
|
|
|
1768 ()
|
|
|
1769 (make-local-variable 'custom-data)
|
|
|
1770 (setq custom-data custom))
|
|
|
1771 (if (null set)
|
|
|
1772 ()
|
|
|
1773 (make-local-variable 'custom-external-set)
|
|
|
1774 (setq custom-external-set set))
|
|
|
1775 (if (null get)
|
|
|
1776 ()
|
|
|
1777 (make-local-variable 'custom-external)
|
|
|
1778 (setq custom-external get))
|
|
|
1779 (if (null save)
|
|
|
1780 ()
|
|
|
1781 (make-local-variable 'custom-save)
|
|
|
1782 (setq custom-save save))
|
|
|
1783 (let ((inhibit-point-motion-hooks t)
|
|
|
1784 (before-change-functions nil)
|
|
|
1785 (after-change-functions nil))
|
|
|
1786 (erase-buffer)
|
|
|
1787 (insert "\n")
|
|
|
1788 (goto-char (point-min))
|
|
|
1789 (custom-text-insert "This is a customization buffer.\n")
|
|
|
1790 (custom-help-insert "\n")
|
|
|
1791 (custom-help-button 'custom-forward-field)
|
|
|
1792 (custom-help-button 'custom-backward-field)
|
|
|
1793 (custom-help-button 'custom-enter-value)
|
|
|
1794 (custom-help-button 'custom-field-factory-reset)
|
|
|
1795 (custom-help-button 'custom-field-reset)
|
|
|
1796 (custom-help-button 'custom-field-apply)
|
|
|
1797 (custom-help-button 'custom-save-and-exit)
|
|
|
1798 (custom-help-button 'custom-toggle-documentation)
|
|
|
1799 (custom-help-insert "\nClick mouse-2 on any button to activate it.\n")
|
|
|
1800 (custom-text-insert "\n")
|
|
|
1801 (custom-insert custom-data 0)
|
|
|
1802 (goto-char (point-min))))
|
|
|
1803
|
|
|
1804 (defun custom-insert (custom level)
|
|
|
1805 "Insert custom declaration CUSTOM in current buffer at level LEVEL."
|
|
|
1806 (if (stringp custom)
|
|
|
1807 (progn
|
|
|
1808 (custom-text-insert custom)
|
|
|
1809 nil)
|
|
|
1810 (and level (null (custom-property custom 'header))
|
|
|
1811 (setq level nil))
|
|
|
1812 (and level
|
|
|
1813 (> level 0)
|
|
|
1814 (custom-text-insert (concat "\n" (make-string level ?*) " ")))
|
|
|
1815 (let ((field (funcall (custom-property custom 'insert) custom level)))
|
|
|
1816 (custom-name-enter (custom-name custom) field)
|
|
|
1817 field)))
|
|
|
1818
|
|
|
1819 (defun custom-text-insert (text)
|
|
|
1820 "Insert TEXT in current buffer."
|
|
|
1821 (insert text))
|
|
|
1822
|
|
|
1823 (defun custom-tag-insert (tag field &optional data)
|
|
|
1824 "Insert TAG for FIELD in current buffer."
|
|
|
1825 (let ((from (point)))
|
|
|
1826 (insert tag)
|
|
|
1827 (custom-category-set from (point) 'custom-button-properties)
|
|
|
1828 (put-text-property from (point) 'custom-tag field)
|
|
|
1829 (if data
|
|
|
1830 (add-text-properties from (point) (list 'custom-data data)))))
|
|
|
1831
|
|
|
1832 (defun custom-documentation-insert (custom &rest ignore)
|
|
|
1833 "Insert documentation from CUSTOM in current buffer."
|
|
|
1834 (let ((doc (custom-documentation custom)))
|
|
|
1835 (if (null doc)
|
|
|
1836 ()
|
|
|
1837 (custom-help-insert "\n" doc))))
|
|
|
1838
|
|
|
1839 (defun custom-help-insert (&rest args)
|
|
|
1840 "Insert ARGS as documentation text."
|
|
|
1841 (let ((from (point)))
|
|
|
1842 (apply 'insert args)
|
|
|
1843 (custom-category-set from (point) 'custom-documentation-properties)))
|
|
|
1844
|
|
|
1845 (defun custom-help-button (command)
|
|
|
1846 "Describe how to execute COMMAND."
|
|
|
1847 (let ((from (point)))
|
|
|
1848 (insert "`" (key-description (where-is-internal command nil t)) "'")
|
|
|
1849 (set-text-properties from (point)
|
|
|
1850 (list 'face custom-button-face
|
|
|
1851 mouse-face custom-mouse-face
|
|
|
1852 'custom-jump t ;Make TAB jump over it.
|
|
|
1853 'custom-tag command))
|
|
|
1854 (custom-category-set from (point) 'custom-documentation-properties))
|
|
|
1855 (custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
|
|
|
1856
|
|
|
1857 ;;; Mode:
|
|
|
1858 ;;
|
|
|
1859 ;; The Customization major mode and interactive commands.
|
|
|
1860
|
|
|
1861 (defvar custom-mode-map nil
|
|
14032
|
1862 "Keymap for Custom Mode.")
|
|
13401
|
1863 (if custom-mode-map
|
|
|
1864 nil
|
|
|
1865 (setq custom-mode-map (make-sparse-keymap))
|
|
|
1866 (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button)
|
|
|
1867 (define-key custom-mode-map "\t" 'custom-forward-field)
|
|
|
1868 (define-key custom-mode-map "\M-\t" 'custom-backward-field)
|
|
|
1869 (define-key custom-mode-map "\r" 'custom-enter-value)
|
|
|
1870 (define-key custom-mode-map "\C-k" 'custom-kill-line)
|
|
|
1871 (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
|
|
|
1872 (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
|
|
|
1873 (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset)
|
|
|
1874 (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all)
|
|
|
1875 (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
|
|
|
1876 (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
|
|
|
1877 (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit)
|
|
|
1878 (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
|
|
|
1879
|
|
|
1880 ;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
|
|
|
1881 ;; forward-field, C-b backward-field, C-n next-field, C-p
|
|
|
1882 ;; previous-field, ? describe-field.
|
|
|
1883
|
|
|
1884 (defun custom-mode ()
|
|
|
1885 "Major mode for doing customizations.
|
|
|
1886
|
|
|
1887 \\{custom-mode-map}"
|
|
|
1888 (kill-all-local-variables)
|
|
|
1889 (setq major-mode 'custom-mode
|
|
|
1890 mode-name "Custom")
|
|
|
1891 (use-local-map custom-mode-map)
|
|
|
1892 (make-local-variable 'before-change-functions)
|
|
|
1893 (setq before-change-functions '(custom-before-change))
|
|
|
1894 (make-local-variable 'after-change-functions)
|
|
|
1895 (setq after-change-functions '(custom-after-change))
|
|
|
1896 (if (not (fboundp 'make-local-hook))
|
|
|
1897 ;; Emacs 19.28 and earlier.
|
|
|
1898 (add-hook 'post-command-hook
|
|
|
1899 (lambda ()
|
|
|
1900 (if (eq major-mode 'custom-mode)
|
|
|
1901 (custom-post-command))))
|
|
|
1902 ;; Emacs 19.29.
|
|
|
1903 (make-local-hook 'post-command-hook)
|
|
|
1904 (add-hook 'post-command-hook 'custom-post-command nil t)))
|
|
|
1905
|
|
|
1906 (defun custom-forward-field (arg)
|
|
|
1907 "Move point to the next field or button.
|
|
|
1908 With optional ARG, move across that many fields."
|
|
|
1909 (interactive "p")
|
|
|
1910 (while (> arg 0)
|
|
|
1911 (let ((next (if (get-text-property (point) 'custom-tag)
|
|
|
1912 (next-single-property-change (point) 'custom-tag)
|
|
|
1913 (point))))
|
|
|
1914 (setq next (or (next-single-property-change next 'custom-tag)
|
|
|
1915 (next-single-property-change (point-min) 'custom-tag)))
|
|
|
1916 (if next
|
|
|
1917 (goto-char next)
|
|
|
1918 (error "No customization fields in this buffer.")))
|
|
|
1919 (or (get-text-property (point) 'custom-jump)
|
|
|
1920 (setq arg (1- arg))))
|
|
|
1921 (while (< arg 0)
|
|
|
1922 (let ((previous (if (get-text-property (1- (point)) 'custom-tag)
|
|
|
1923 (previous-single-property-change (point) 'custom-tag)
|
|
|
1924 (point))))
|
|
|
1925 (setq previous
|
|
|
1926 (or (previous-single-property-change previous 'custom-tag)
|
|
|
1927 (previous-single-property-change (point-max) 'custom-tag)))
|
|
|
1928 (if previous
|
|
|
1929 (goto-char previous)
|
|
|
1930 (error "No customization fields in this buffer.")))
|
|
|
1931 (or (get-text-property (1- (point)) 'custom-jump)
|
|
|
1932 (setq arg (1+ arg)))))
|
|
|
1933
|
|
|
1934 (defun custom-backward-field (arg)
|
|
|
1935 "Move point to the previous field or button.
|
|
|
1936 With optional ARG, move across that many fields."
|
|
|
1937 (interactive "p")
|
|
|
1938 (custom-forward-field (- arg)))
|
|
|
1939
|
|
|
1940 (defun custom-toggle-documentation (&optional arg)
|
|
|
1941 "Toggle display of documentation text.
|
|
|
1942 If the optional argument is non-nil, show text iff the argument is positive."
|
|
|
1943 (interactive "P")
|
|
|
1944 (let ((hide (or (and (null arg)
|
|
|
1945 (null (custom-category-get
|
|
|
1946 'custom-documentation-properties 'invisible)))
|
|
|
1947 (<= (prefix-numeric-value arg) 0))))
|
|
|
1948 (custom-category-put 'custom-documentation-properties 'invisible hide)
|
|
|
1949 (custom-category-put 'custom-documentation-properties intangible hide))
|
|
|
1950 (redraw-display))
|
|
|
1951
|
|
|
1952 (defun custom-enter-value (field data)
|
|
|
1953 "Enter value for current customization field or push button."
|
|
|
1954 (interactive (list (get-text-property (point) 'custom-tag)
|
|
|
1955 (get-text-property (point) 'custom-data)))
|
|
|
1956 (cond (data
|
|
|
1957 (funcall field data))
|
|
|
1958 ((eq field 'custom-enter-value)
|
|
|
1959 (error "Don't be silly"))
|
|
|
1960 ((and (symbolp field) (fboundp field))
|
|
|
1961 (call-interactively field))
|
|
|
1962 (field
|
|
|
1963 (custom-field-query field))
|
|
|
1964 (t
|
|
|
1965 (message "Nothing to enter here"))))
|
|
|
1966
|
|
|
1967 (defun custom-kill-line ()
|
|
|
1968 "Kill to end of field or end of line, whichever is first."
|
|
|
1969 (interactive)
|
|
|
1970 (let ((field (get-text-property (point) 'custom-field))
|
|
|
1971 (newline (save-excursion (search-forward "\n")))
|
|
|
1972 (next (next-single-property-change (point) 'custom-field)))
|
|
|
1973 (if (and field (> newline next))
|
|
|
1974 (kill-region (point) next)
|
|
|
1975 (call-interactively 'kill-line))))
|
|
|
1976
|
|
|
1977 (defun custom-push-button (event)
|
|
|
1978 "Activate button below mouse pointer."
|
|
|
1979 (interactive "@e")
|
|
|
1980 (let* ((pos (event-point event))
|
|
|
1981 (field (get-text-property pos 'custom-field))
|
|
|
1982 (tag (get-text-property pos 'custom-tag))
|
|
|
1983 (data (get-text-property pos 'custom-data)))
|
|
|
1984 (cond (data
|
|
|
1985 (funcall tag data))
|
|
|
1986 ((and (symbolp tag) (fboundp tag))
|
|
|
1987 (call-interactively tag))
|
|
|
1988 (field
|
|
|
1989 (call-interactively (lookup-key global-map (this-command-keys))))
|
|
|
1990 (tag
|
|
|
1991 (custom-enter-value tag data))
|
|
|
1992 (t
|
|
|
1993 (error "Nothing to click on here.")))))
|
|
|
1994
|
|
|
1995 (defun custom-reset-all ()
|
|
|
1996 "Undo any changes since the last apply in all fields."
|
|
|
1997 (interactive (and custom-modified-list
|
|
|
1998 (not (y-or-n-p "Discard all changes? "))
|
|
|
1999 (error "Reset aborted")))
|
|
|
2000 (let ((all custom-name-fields)
|
|
|
2001 current field)
|
|
|
2002 (while all
|
|
|
2003 (setq current (car all)
|
|
|
2004 field (cdr current)
|
|
|
2005 all (cdr all))
|
|
|
2006 (custom-field-reset field))))
|
|
|
2007
|
|
|
2008 (defun custom-field-reset (field)
|
|
|
2009 "Undo any changes in FIELD since the last apply."
|
|
|
2010 (interactive (list (or (get-text-property (point) 'custom-field)
|
|
|
2011 (get-text-property (point) 'custom-tag))))
|
|
|
2012 (if (arrayp field)
|
|
|
2013 (let* ((custom (custom-field-custom field))
|
|
|
2014 (name (custom-name custom)))
|
|
|
2015 (save-excursion
|
|
|
2016 (if name
|
|
|
2017 (custom-field-original-set
|
|
|
2018 field (car (custom-import custom (custom-external name)))))
|
|
|
2019 (if (not (custom-valid custom (custom-field-original field)))
|
|
|
2020 (error "This field cannot be reset alone")
|
|
|
2021 (funcall (custom-property custom 'reset) field)
|
|
|
2022 (funcall (custom-property custom 'synchronize) field))))))
|
|
|
2023
|
|
|
2024 (defun custom-factory-reset-all ()
|
|
|
2025 "Reset all field to their default values."
|
|
|
2026 (interactive (and custom-modified-list
|
|
|
2027 (not (y-or-n-p "Discard all changes? "))
|
|
|
2028 (error "Reset aborted")))
|
|
|
2029 (let ((all custom-name-fields)
|
|
|
2030 field)
|
|
|
2031 (while all
|
|
|
2032 (setq field (cdr (car all))
|
|
|
2033 all (cdr all))
|
|
|
2034 (custom-field-factory-reset field))))
|
|
|
2035
|
|
|
2036 (defun custom-field-factory-reset (field)
|
|
|
2037 "Reset FIELD to its default value."
|
|
|
2038 (interactive (list (or (get-text-property (point) 'custom-field)
|
|
|
2039 (get-text-property (point) 'custom-tag))))
|
|
|
2040 (if (arrayp field)
|
|
|
2041 (save-excursion
|
|
|
2042 (funcall (custom-property (custom-field-custom field) 'factory-reset)
|
|
|
2043 field))))
|
|
|
2044
|
|
|
2045 (defun custom-apply-all ()
|
|
|
2046 "Apply any changes since the last reset in all fields."
|
|
|
2047 (interactive (if custom-modified-list
|
|
|
2048 nil
|
|
|
2049 (error "No changes to apply.")))
|
|
|
2050 (custom-field-parse custom-field-last)
|
|
|
2051 (let ((all custom-name-fields)
|
|
|
2052 field)
|
|
|
2053 (while all
|
|
|
2054 (setq field (cdr (car all))
|
|
|
2055 all (cdr all))
|
|
|
2056 (let ((error (custom-field-validate (custom-field-custom field) field)))
|
|
|
2057 (if (null error)
|
|
|
2058 ()
|
|
|
2059 (goto-char (car error))
|
|
|
2060 (error (cdr error))))))
|
|
|
2061 (let ((all custom-name-fields)
|
|
|
2062 field)
|
|
|
2063 (while all
|
|
|
2064 (setq field (cdr (car all))
|
|
|
2065 all (cdr all))
|
|
|
2066 (custom-field-apply field))))
|
|
|
2067
|
|
|
2068 (defun custom-field-apply (field)
|
|
|
2069 "Apply any changes in FIELD since the last apply."
|
|
|
2070 (interactive (list (or (get-text-property (point) 'custom-field)
|
|
|
2071 (get-text-property (point) 'custom-tag))))
|
|
|
2072 (custom-field-parse custom-field-last)
|
|
|
2073 (if (arrayp field)
|
|
|
2074 (let* ((custom (custom-field-custom field))
|
|
|
2075 (error (custom-field-validate custom field)))
|
|
|
2076 (if error
|
|
|
2077 (error (cdr error)))
|
|
|
2078 (funcall (custom-property custom 'apply) field))))
|
|
|
2079
|
|
|
2080 (defun custom-toggle-hide (&rest ignore)
|
|
|
2081 "Hide or show entry."
|
|
|
2082 (interactive)
|
|
|
2083 (error "This button is not yet implemented"))
|
|
|
2084
|
|
|
2085 (defun custom-save-and-exit ()
|
|
|
2086 "Save and exit customization buffer."
|
|
|
2087 (interactive "@")
|
|
|
2088 (save-excursion
|
|
|
2089 (funcall custom-save))
|
|
|
2090 (kill-buffer (current-buffer)))
|
|
|
2091
|
|
|
2092 (defun custom-save ()
|
|
|
2093 "Save customization information."
|
|
|
2094 (interactive)
|
|
|
2095 (custom-apply-all)
|
|
|
2096 (let ((new custom-name-fields))
|
|
|
2097 (set-buffer (find-file-noselect custom-file))
|
|
|
2098 (goto-char (point-min))
|
|
|
2099 (save-excursion
|
|
|
2100 (let ((old (condition-case nil
|
|
|
2101 (read (current-buffer))
|
|
|
2102 (end-of-file (append '(setq custom-dummy
|
|
|
2103 'custom-dummy) ())))))
|
|
|
2104 (or (eq (car old) 'setq)
|
|
|
2105 (error "Invalid customization file: %s" custom-file))
|
|
|
2106 (while new
|
|
|
2107 (let* ((field (cdr (car new)))
|
|
|
2108 (custom (custom-field-custom field))
|
|
|
2109 (value (custom-field-original field))
|
|
|
2110 (default (car (custom-import custom (custom-default custom))))
|
|
|
2111 (name (car (car new))))
|
|
|
2112 (setq new (cdr new))
|
|
|
2113 (custom-assert '(eq name (custom-name custom)))
|
|
|
2114 (if (equal default value)
|
|
|
2115 (setcdr old (custom-plist-delq name (cdr old)))
|
|
|
2116 (setcdr old (plist-put (cdr old) name
|
|
|
2117 (car (custom-quote custom value)))))))
|
|
|
2118 (erase-buffer)
|
|
|
2119 (insert ";; " custom-file "\
|
|
|
2120 --- Automatically generated customization information.
|
|
|
2121 ;;
|
|
|
2122 ;; Feel free to edit by hand, but the entire content should consist of
|
|
|
2123 ;; a single setq. Any other lisp expressions will confuse the
|
|
|
2124 ;; automatic configuration engine.
|
|
|
2125
|
|
|
2126 \(setq ")
|
|
|
2127 (setq old (cdr old))
|
|
|
2128 (while old
|
|
|
2129 (prin1 (car old) (current-buffer))
|
|
|
2130 (setq old (cdr old))
|
|
|
2131 (insert " ")
|
|
|
2132 (pp (car old) (current-buffer))
|
|
|
2133 (setq old (cdr old))
|
|
|
2134 (if old (insert "\n ")))
|
|
|
2135 (insert ")\n")
|
|
|
2136 (save-buffer)
|
|
|
2137 (kill-buffer (current-buffer))))))
|
|
|
2138
|
|
|
2139 (defun custom-load ()
|
|
|
2140 "Save customization information."
|
|
|
2141 (interactive (and custom-modified-list
|
|
|
2142 (not (equal (list (custom-name-field 'custom-file))
|
|
|
2143 custom-modified-list))
|
|
|
2144 (not (y-or-n-p "Discard all changes? "))
|
|
|
2145 (error "Load aborted")))
|
|
|
2146 (load-file (custom-name-value 'custom-file))
|
|
|
2147 (custom-reset-all))
|
|
|
2148
|
|
|
2149 ;;; Field Editing:
|
|
|
2150 ;;
|
|
|
2151 ;; Various internal functions for implementing the direct editing of
|
|
|
2152 ;; fields in the customization buffer.
|
|
|
2153
|
|
|
2154 (defun custom-field-untouch (field)
|
|
|
2155 ;; Remove FIELD and its children from `custom-modified-list'.
|
|
|
2156 (setq custom-modified-list (delq field custom-modified-list))
|
|
|
2157 (if (arrayp field)
|
|
|
2158 (let ((value (custom-field-value field)))
|
|
|
2159 (cond ((null (custom-data (custom-field-custom field))))
|
|
|
2160 ((arrayp value)
|
|
|
2161 (custom-field-untouch value))
|
|
|
2162 ((listp value)
|
|
|
2163 (mapcar 'custom-field-untouch value))))))
|
|
|
2164
|
|
|
2165
|
|
|
2166 (defun custom-field-insert (field)
|
|
|
2167 ;; Insert editing FIELD in current buffer.
|
|
|
2168 (let ((from (point))
|
|
|
2169 (custom (custom-field-custom field))
|
|
|
2170 (value (custom-field-value field)))
|
|
|
2171 (insert (custom-write custom value))
|
|
|
2172 (insert-char (custom-padding custom)
|
|
|
2173 (- (custom-width custom) (- (point) from)))
|
|
|
2174 (custom-field-move field from (point))
|
|
|
2175 (set-text-properties
|
|
|
2176 from (point)
|
|
|
2177 (list 'custom-field field
|
|
|
2178 'custom-tag field
|
|
|
2179 'face (custom-field-face field)
|
|
|
2180 front-sticky t))))
|
|
|
2181
|
|
|
2182 (defun custom-field-read (field)
|
|
|
2183 ;; Read the screen content of FIELD.
|
|
|
2184 (custom-read (custom-field-custom field)
|
|
|
2185 (buffer-substring-no-properties (custom-field-start field)
|
|
|
2186 (custom-field-end field))))
|
|
|
2187
|
|
|
2188 ;; Fields are shown in a special `active' face when point is inside
|
|
|
2189 ;; it. You activate the field by moving point inside (entering) it
|
|
|
2190 ;; and deactivate the field by moving point outside (leaving) it.
|
|
|
2191
|
|
|
2192 (defun custom-field-leave (field)
|
|
|
2193 ;; Deactivate FIELD.
|
|
|
2194 (let ((before-change-functions nil)
|
|
|
2195 (after-change-functions nil))
|
|
|
2196 (put-text-property (custom-field-start field) (custom-field-end field)
|
|
|
2197 'face (custom-field-face field))))
|
|
|
2198
|
|
|
2199 (defun custom-field-enter (field)
|
|
|
2200 ;; Activate FIELD.
|
|
|
2201 (let* ((start (custom-field-start field))
|
|
|
2202 (end (custom-field-end field))
|
|
|
2203 (custom (custom-field-custom field))
|
|
|
2204 (padding (custom-padding custom))
|
|
|
2205 (before-change-functions nil)
|
|
|
2206 (after-change-functions nil))
|
|
|
2207 (or (eq this-command 'self-insert-command)
|
|
|
2208 (let ((pos end))
|
|
|
2209 (while (and (< start pos)
|
|
|
2210 (eq (char-after (1- pos)) padding))
|
|
|
2211 (setq pos (1- pos)))
|
|
|
2212 (if (< pos (point))
|
|
|
2213 (goto-char pos))))
|
|
|
2214 (put-text-property start end 'face custom-field-active-face)))
|
|
|
2215
|
|
|
2216 (defun custom-field-resize (field)
|
|
|
2217 ;; Resize FIELD after change.
|
|
|
2218 (let* ((custom (custom-field-custom field))
|
|
|
2219 (begin (custom-field-start field))
|
|
|
2220 (end (custom-field-end field))
|
|
|
2221 (pos (point))
|
|
|
2222 (padding (custom-padding custom))
|
|
|
2223 (width (custom-width custom))
|
|
|
2224 (size (- end begin)))
|
|
|
2225 (cond ((< size width)
|
|
|
2226 (goto-char end)
|
|
|
2227 (if (fboundp 'insert-before-markers-and-inherit)
|
|
|
2228 ;; Emacs 19.
|
|
|
2229 (insert-before-markers-and-inherit
|
|
|
2230 (make-string (- width size) padding))
|
|
|
2231 ;; XEmacs: BUG: Doesn't work!
|
|
|
2232 (insert-before-markers (make-string (- width size) padding)))
|
|
|
2233 (goto-char pos))
|
|
|
2234 ((> size width)
|
|
|
2235 (let ((start (if (and (< (+ begin width) pos) (<= pos end))
|
|
|
2236 pos
|
|
|
2237 (+ begin width))))
|
|
|
2238 (goto-char end)
|
|
|
2239 (while (and (< start (point)) (= (preceding-char) padding))
|
|
|
2240 (backward-delete-char 1))
|
|
|
2241 (goto-char pos))))))
|
|
|
2242
|
|
|
2243 (defvar custom-field-changed nil)
|
|
|
2244 ;; List of fields changed on the screen but whose VALUE attribute has
|
|
|
2245 ;; not yet been updated to reflect the new screen content.
|
|
|
2246 (make-variable-buffer-local 'custom-field-changed)
|
|
|
2247
|
|
|
2248 (defun custom-field-parse (field)
|
|
|
2249 ;; Parse FIELD content iff changed.
|
|
|
2250 (if (memq field custom-field-changed)
|
|
|
2251 (progn
|
|
|
2252 (setq custom-field-changed (delq field custom-field-changed))
|
|
|
2253 (custom-field-value-set field (custom-field-read field))
|
|
|
2254 (custom-field-update field))))
|
|
|
2255
|
|
|
2256 (defun custom-post-command ()
|
|
|
2257 ;; Keep track of their active field.
|
|
|
2258 (custom-assert '(eq major-mode 'custom-mode))
|
|
|
2259 (let ((field (custom-field-property (point))))
|
|
|
2260 (if (eq field custom-field-last)
|
|
|
2261 (if (memq field custom-field-changed)
|
|
|
2262 (custom-field-resize field))
|
|
|
2263 (custom-field-parse custom-field-last)
|
|
|
2264 (if custom-field-last
|
|
|
2265 (custom-field-leave custom-field-last))
|
|
|
2266 (if field
|
|
|
2267 (custom-field-enter field))
|
|
|
2268 (setq custom-field-last field))
|
|
|
2269 (set-buffer-modified-p (or custom-modified-list
|
|
|
2270 custom-field-changed))))
|
|
|
2271
|
|
|
2272 (defvar custom-field-was nil)
|
|
|
2273 ;; The custom data before the change.
|
|
|
2274 (make-variable-buffer-local 'custom-field-was)
|
|
|
2275
|
|
|
2276 (defun custom-before-change (begin end)
|
|
|
2277 ;; Check that we the modification is allowed.
|
|
|
2278 (if (not (eq major-mode 'custom-mode))
|
|
|
2279 (message "Aargh! Why is custom-before-change called here?")
|
|
|
2280 (let ((from (custom-field-property begin))
|
|
|
2281 (to (custom-field-property end)))
|
|
|
2282 (cond ((or (null from) (null to))
|
|
|
2283 (error "You can only modify the fields"))
|
|
|
2284 ((not (eq from to))
|
|
|
2285 (error "Changes must be limited to a single field."))
|
|
|
2286 (t
|
|
|
2287 (setq custom-field-was from))))))
|
|
|
2288
|
|
|
2289 (defun custom-after-change (begin end length)
|
|
|
2290 ;; Keep track of field content.
|
|
|
2291 (if (not (eq major-mode 'custom-mode))
|
|
|
2292 (message "Aargh! Why is custom-after-change called here?")
|
|
|
2293 (let ((field custom-field-was))
|
|
|
2294 (custom-assert '(prog1 field (setq custom-field-was nil)))
|
|
|
2295 ;; Prevent mixing fields properties.
|
|
|
2296 (put-text-property begin end 'custom-field field)
|
|
|
2297 ;; Update the field after modification.
|
|
|
2298 (if (eq (custom-field-property begin) field)
|
|
|
2299 (let ((field-end (custom-field-end field)))
|
|
|
2300 (if (> end field-end)
|
|
|
2301 (set-marker field-end end))
|
|
|
2302 (add-to-list 'custom-field-changed field))
|
|
|
2303 ;; We deleted the entire field, reinsert it.
|
|
|
2304 (custom-assert '(eq begin end))
|
|
|
2305 (save-excursion
|
|
|
2306 (goto-char begin)
|
|
|
2307 (custom-field-value-set field
|
|
|
2308 (custom-read (custom-field-custom field) ""))
|
|
|
2309 (custom-field-insert field))))))
|
|
|
2310
|
|
|
2311 (defun custom-field-property (pos)
|
|
|
2312 ;; The `custom-field' text property valid for POS.
|
|
|
2313 (or (get-text-property pos 'custom-field)
|
|
|
2314 (and (not (eq pos (point-min)))
|
|
|
2315 (get-text-property (1- pos) 'custom-field))))
|
|
|
2316
|
|
|
2317 ;;; Generic Utilities:
|
|
|
2318 ;;
|
|
|
2319 ;; Some utility functions that are not really specific to custom.
|
|
|
2320
|
|
|
2321 (defun custom-assert (expr)
|
|
|
2322 "Assert that EXPR evaluates to non-nil at this point"
|
|
|
2323 (or (eval expr)
|
|
|
2324 (error "Assertion failed: %S" expr)))
|
|
|
2325
|
|
|
2326 (defun custom-first-line (string)
|
|
|
2327 "Return the part of STRING before the first newline."
|
|
|
2328 (let ((pos 0)
|
|
|
2329 (len (length string)))
|
|
|
2330 (while (and (< pos len) (not (eq (aref string pos) ?\n)))
|
|
|
2331 (setq pos (1+ pos)))
|
|
|
2332 (if (eq pos len)
|
|
|
2333 string
|
|
|
2334 (substring string 0 pos))))
|
|
|
2335
|
|
|
2336 (defun custom-insert-before (list old new)
|
|
|
2337 "In LIST insert before OLD a NEW element."
|
|
|
2338 (cond ((null list)
|
|
|
2339 (list new))
|
|
|
2340 ((null old)
|
|
|
2341 (nconc list (list new)))
|
|
|
2342 ((eq old (car list))
|
|
|
2343 (cons new list))
|
|
|
2344 (t
|
|
|
2345 (let ((list list))
|
|
|
2346 (while (not (eq old (car (cdr list))))
|
|
|
2347 (setq list (cdr list))
|
|
|
2348 (custom-assert '(cdr list)))
|
|
|
2349 (setcdr list (cons new (cdr list))))
|
|
|
2350 list)))
|
|
|
2351
|
|
|
2352 (defun custom-strip-padding (string padding)
|
|
|
2353 "Remove padding from STRING."
|
|
|
2354 (let ((regexp (concat (regexp-quote (char-to-string padding)) "+")))
|
|
|
2355 (while (string-match regexp string)
|
|
|
2356 (setq string (concat (substring string 0 (match-beginning 0))
|
|
|
2357 (substring string (match-end 0))))))
|
|
|
2358 string)
|
|
|
2359
|
|
|
2360 (defun custom-plist-memq (prop plist)
|
|
|
2361 "Return non-nil if PROP is a property of PLIST. Comparison done with EQ."
|
|
|
2362 (let (result)
|
|
|
2363 (while plist
|
|
|
2364 (if (eq (car plist) prop)
|
|
|
2365 (setq result plist
|
|
|
2366 plist nil)
|
|
|
2367 (setq plist (cdr (cdr plist)))))
|
|
|
2368 result))
|
|
|
2369
|
|
|
2370 (defun custom-plist-delq (prop plist)
|
|
|
2371 "Delete property PROP from property list PLIST."
|
|
|
2372 (while (eq (car plist) prop)
|
|
|
2373 (setq plist (cdr (cdr plist))))
|
|
|
2374 (let ((list plist)
|
|
|
2375 (next (cdr (cdr plist))))
|
|
|
2376 (while next
|
|
|
2377 (if (eq (car next) prop)
|
|
|
2378 (progn
|
|
|
2379 (setq next (cdr (cdr next)))
|
|
|
2380 (setcdr (cdr list) next))
|
|
|
2381 (setq list next
|
|
|
2382 next (cdr (cdr next))))))
|
|
|
2383 plist)
|
|
|
2384
|
|
|
2385 ;;; Meta Customization:
|
|
|
2386
|
|
|
2387 (custom-declare '()
|
|
|
2388 '((tag . "Meta Customization")
|
|
|
2389 (doc . "Customization of the customization support.")
|
|
|
2390 (type . group)
|
|
|
2391 (data ((type . face-doc))
|
|
|
2392 ((tag . "Button Face")
|
|
|
2393 (default . bold)
|
|
|
2394 (doc . "Face used for tags in customization buffers.")
|
|
|
2395 (name . custom-button-face)
|
|
|
2396 (synchronize . (lambda (f)
|
|
|
2397 (custom-category-put 'custom-button-properties
|
|
|
2398 'face custom-button-face)))
|
|
|
2399 (type . face))
|
|
|
2400 ((tag . "Mouse Face")
|
|
|
2401 (default . highlight)
|
|
|
2402 (doc . "\
|
|
|
2403 Face used when mouse is above a button in customization buffers.")
|
|
|
2404 (name . custom-mouse-face)
|
|
|
2405 (synchronize . (lambda (f)
|
|
|
2406 (custom-category-put 'custom-button-properties
|
|
|
2407 mouse-face
|
|
|
2408 custom-mouse-face)))
|
|
|
2409 (type . face))
|
|
|
2410 ((tag . "Field Face")
|
|
|
2411 (default . italic)
|
|
|
2412 (doc . "Face used for customization fields.")
|
|
|
2413 (name . custom-field-face)
|
|
|
2414 (type . face))
|
|
|
2415 ((tag . "Uninitialized Face")
|
|
|
2416 (default . modeline)
|
|
|
2417 (doc . "Face used for uninitialized customization fields.")
|
|
|
2418 (name . custom-field-uninitialized-face)
|
|
|
2419 (type . face))
|
|
|
2420 ((tag . "Invalid Face")
|
|
|
2421 (default . highlight)
|
|
|
2422 (doc . "\
|
|
|
2423 Face used for customization fields containing invalid data.")
|
|
|
2424 (name . custom-field-invalid-face)
|
|
|
2425 (type . face))
|
|
|
2426 ((tag . "Modified Face")
|
|
|
2427 (default . bold-italic)
|
|
|
2428 (doc . "Face used for modified customization fields.")
|
|
|
2429 (name . custom-field-modified-face)
|
|
|
2430 (type . face))
|
|
|
2431 ((tag . "Active Face")
|
|
|
2432 (default . underline)
|
|
|
2433 (doc . "\
|
|
|
2434 Face used for customization fields while they are being edited.")
|
|
|
2435 (name . custom-field-active-face)
|
|
|
2436 (type . face)))))
|
|
|
2437
|
|
|
2438 ;; custom.el uses two categories.
|
|
|
2439
|
|
|
2440 (custom-category-create 'custom-documentation-properties)
|
|
|
2441 (custom-category-put 'custom-documentation-properties rear-nonsticky t)
|
|
|
2442
|
|
|
2443 (custom-category-create 'custom-button-properties)
|
|
|
2444 (custom-category-put 'custom-button-properties 'face custom-button-face)
|
|
|
2445 (custom-category-put 'custom-button-properties mouse-face custom-mouse-face)
|
|
|
2446 (custom-category-put 'custom-button-properties rear-nonsticky t)
|
|
|
2447
|
|
|
2448 (custom-category-create 'custom-hidden-properties)
|
|
|
2449 (custom-category-put 'custom-hidden-properties 'invisible
|
|
|
2450 (not (string-match "XEmacs" emacs-version)))
|
|
|
2451 (custom-category-put 'custom-hidden-properties intangible t)
|
|
|
2452
|
|
|
2453 (if (file-readable-p custom-file)
|
|
|
2454 (load-file custom-file))
|
|
|
2455
|
|
|
2456 (provide 'custom)
|
|
|
2457
|
|
|
2458 ;;; custom.el ends here
|
