1 ;;; custom.el --- User friendly customization support.
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
10 ;; WARNING: This package is still under construction and not all of
11 ;; the features below are implemented.
13 ;; This package provides a framework for adding user friendly
14 ;; customization support to Emacs. Having to do customization by
15 ;; editing a text file in some arcane syntax is user hostile in the
16 ;; extreme, and to most users emacs lisp definitely count as arcane.
18 ;; The intension is that authors of emacs lisp packages declare the
19 ;; variables intended for user customization with `custom-declare'.
20 ;; Custom can then automatically generate a customization buffer with
21 ;; `custom-buffer-create' where the user can edit the package
22 ;; variables in a simple and intuitive way, as well as a menu with
23 ;; `custom-menu-create' where he can set the more commonly used
24 ;; variables interactively.
26 ;; It is also possible to use custom for modifying the properties of
27 ;; other objects than the package itself, by specifying extra optional
28 ;; arguments to `custom-buffer-create'.
30 ;; Custom is inspired by OPEN LOOK property windows.
34 ;; - Toggle documentation in three states `none', `one-line', `full'.
35 ;; - Add description of faces to buffer and mode.
36 ;; - Function to generate a XEmacs menu from a CUSTOM.
37 ;; - Add support for customizing packages.
38 ;; - Make it possible to hide sections by clicling at the level stars.
39 ;; - Declare AUC TeX variables.
40 ;; - Declare (ding) Gnus variables.
41 ;; - Declare Emacs variables.
42 ;; - Implement remaining types.
49 (or (fboundp 'buffer-substring-no-properties)
50 ;; Introduced in Emacs 19.29.
51 (defun buffer-substring-no-properties (beg end)
52 "Return the text from BEG to END, without text properties, as a string."
53 (let ((string (buffer-substring beg end)))
54 (set-text-properties 0 (length string) nil string)
57 (or (fboundp 'add-to-list)
58 ;; Introduced in Emacs 19.29.
59 (defun add-to-list (list-var element)
60 "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
61 If you want to use `add-to-list' on a variable that is not defined
62 until a certain package is loaded, you should put the call to `add-to-list'
63 into a hook function that will be run only after loading the package.
64 `eval-after-load' provides one way to do this. In some cases
65 other hooks, such as major mode hooks, can do the job."
66 (or (member element (symbol-value list-var))
67 (set list-var (cons element (symbol-value list-var))))))
69 (defvar intangible nil
70 "The symbol making text intangible")
72 ;; We can't easily check for a working intangible.
73 (if (and (boundp 'emacs-minor-version)
74 (or (> emacs-major-version 19)
75 (and (> emacs-major-version 18)
76 (> emacs-minor-version 28))))
77 (setq intangible 'intangible)
78 (setq intangible 'intangible-if-it-had-been-working))
82 ;; The following variables define the faces used in the customization
85 (defvar custom-button-face 'bold
86 "Face used for tags in customization buffers.")
88 (defvar custom-field-uninitialized-face 'modeline
89 "Face used for uninitialized customization fields.")
91 (defvar custom-field-invalid-face 'highlight
92 "Face used for customization fields containing invalid data.")
94 (defvar custom-field-modified-face 'bold-italic
95 "Face used for modified customization fields.")
97 (defvar custom-field-active-face 'underline
98 "Face used for customization fields while they are being edited.")
100 (defvar custom-field-face 'italic
101 "Face used for customization fields.")
103 (defvar custom-mouse-face 'highlight
104 "Face used for tags in customization buffers.")
106 (defvar custom-documentation-properties 'custom-documentation-properties
107 "The properties of this symbol will be in effect for all documentation.")
108 (put custom-documentation-properties 'rear-nonsticky t)
110 (defvar custom-button-properties 'custom-button-properties
111 "The properties of this symbol will be in effect for all buttons.")
112 (put custom-button-properties 'face custom-button-face)
113 (put custom-button-properties 'mouse-face custom-mouse-face)
114 (put custom-button-properties 'rear-nonsticky t)
118 ;; The following functions and variables defines the interface for
119 ;; connecting a CUSTOM with an external entity, by default an emacs
122 (defvar custom-external 'default-value
123 "Function returning the external value of NAME.")
125 (defvar custom-external-set 'set-default
126 "Function setting the external value of NAME to VALUE.")
128 (defun custom-external (name)
129 "Get the external value associated with NAME."
130 (funcall custom-external name))
132 (defun custom-external-set (name value)
133 "Set the external value associated with NAME to VALUE."
134 (funcall custom-external-set name value))
136 (defvar custom-name-fields nil
137 "Alist of custom names and their associated editing field.")
138 (make-variable-buffer-local 'custom-name-fields)
140 (defun custom-name-enter (name field)
141 "Associate NAME with FIELD."
144 (custom-assert 'field)
145 (setq custom-name-fields (cons (cons name field) custom-name-fields))))
147 (defun custom-name-value (name)
148 "The value currently displayed for NAME in the customization buffer."
149 (let ((field (cdr (assq name custom-name-fields))))
150 (car (custom-field-extract (custom-field-custom field) field))))
152 ;;; Custom Functions:
154 ;; The following functions are part of the public interface to the
155 ;; CUSTOM datastructure. Each CUSTOM describes a group of variables,
156 ;; a single variable, or a component of a structured variable. The
157 ;; CUSTOM instances are part of two hiearachies, the first is the
158 ;; `part-of' hierarchy in which each CUSTOM is a component of another
159 ;; CUSTOM, except for the top level CUSTOM which is contained in
160 ;; `custom-data'. The second hiearachy is a `is-a' type hierarchy
161 ;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
162 ;; property and `custom-type-properties'.
164 (defconst custom-data
166 (doc . "The extensible self-documenting text editor.")
169 "The global customization information.
170 A custom association list.")
172 (defconst custom-type-properties
173 '((repeat (type . default)
174 (accept . custom-repeat-accept)
175 (extract . custom-repeat-extract)
176 (validate . custom-repeat-validate)
177 (insert . custom-repeat-insert)
178 (match . custom-repeat-match)
179 (query . custom-repeat-query)
183 (extract . custom-list-extract)
184 (validate . custom-list-validate)
185 (check . custom-list-check))
186 (group (type . default)
189 (query . custom-toggle-hide)
190 (accept . custom-group-accept)
191 (insert . custom-group-insert))
192 (toggle (type . choice)
193 (data ((type . const)
199 (choice (type . default)
200 (query . custom-choice-query)
201 (accept . custom-choice-accept)
202 (extract . custom-choice-extract)
203 (validate . custom-choice-validate)
204 (check . custom-choice-check)
205 (insert . custom-choice-insert)
206 (none (tag . "Unknown")
207 (default . __uninitialized__)
209 (const (type . default)
211 (extract . (lambda (c f) (list (custom-default c))))
212 (validate . (lambda (c f) nil))
213 (valid . custom-const-valid)
214 (insert . custom-const-insert))
215 (file (type . string)
218 (query . custom-file-query))
219 (integer (type . default)
221 (valid . (lambda (c d) (integerp d)))
222 (allow-padding . nil)
223 (read . custom-integer-read)
224 (write . custom-integer-write))
225 (string (type . default)
227 (valid . (lambda (c d) (stringp d)))
228 (read . custom-string-read)
229 (write . custom-string-write))
230 (button (type . default)
234 (insert . custom-button-insert))
235 (doc (type . default)
239 (insert . custom-documentation-insert))
240 (default (width . 20)
241 (valid . (lambda (c v) t))
242 (insert . custom-default-insert)
243 (query . custom-default-query)
249 (extract . custom-default-extract)
250 (validate . custom-default-validate)
251 (reset . custom-default-reset)
252 (accept . custom-default-accept)
253 (match . custom-default-match)
256 (default . __uninitialized__)))
257 "Alist of default properties for type symbols.
258 The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.")
260 (defconst custom-local-type-properties nil
261 "Local type properties.")
262 (make-variable-buffer-local 'custom-local-type-properties)
264 (defconst custom-nil '__uninitialized__
265 "Special value representing an uninitialized field.")
267 (defun custom-property (custom property)
268 "Extract from CUSTOM property PROPERTY."
269 (let ((entry (assq property custom)))
271 ;; Look in superclass.
272 (let ((type (custom-type custom)))
273 (setq custom (cdr (or (assq type custom-local-type-properties)
274 (assq type custom-type-properties)))
275 entry (assq property custom))
276 (custom-assert 'custom)))
279 (defun custom-type (custom)
280 "Extract `type' from CUSTOM."
281 (cdr (assq 'type custom)))
283 (defun custom-name (custom)
284 "Extract `name' from CUSTOM."
285 (custom-property custom 'name))
287 (defun custom-tag (custom)
288 "Extract `tag' from CUSTOM."
289 (custom-property custom 'tag))
291 (defun custom-tag-or-type (custom)
292 "Extract `tag' from CUSTOM. If none exist, create one from `type'"
293 (or (custom-property custom 'tag)
294 (capitalize (symbol-name (custom-type custom)))))
296 (defun custom-default (custom)
297 "Extract `default' from CUSTOM."
298 (custom-property custom 'default))
300 (defun custom-data (custom)
301 "Extract the `data' from CUSTOM."
302 (custom-property custom 'data))
304 (defun custom-documentation (custom)
305 "Extract `doc' from CUSTOM."
306 (custom-property custom 'doc))
308 (defun custom-width (custom)
309 "Extract `width' from CUSTOM."
310 (custom-property custom 'width))
312 (defun custom-compact (custom)
313 "Extract `compact' from CUSTOM."
314 (custom-property custom 'compact))
316 (defun custom-padding (custom)
317 "Extract `padding' from CUSTOM."
318 (custom-property custom 'padding))
320 (defun custom-allow-padding (custom)
321 "Extract `allow-padding' from CUSTOM."
322 (custom-property custom 'allow-padding))
324 (defun custom-valid (custom value)
325 "Non-nil if CUSTOM may legally be set to VALUE."
326 (funcall (custom-property custom 'valid) custom value))
328 (defun custom-write (custom value)
329 "Convert CUSTOM VALUE to a string."
330 (if (eq value custom-nil)
332 (funcall (custom-property custom 'write) custom value)))
334 (defun custom-read (custom string)
335 "Convert CUSTOM field content STRING into external form."
336 (funcall (custom-property custom 'read) custom string))
338 (defun custom-match (custom values)
339 "Match CUSTOM with a list of VALUES.
340 Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
341 and the cdr is the remaining VALUES."
342 (if (memq values (list custom-nil nil))
343 (cons custom-nil nil)
344 (funcall (custom-property custom 'match) custom values)))
346 (defun custom-field-extract (custom field)
347 "Extract CUSTOM's value in FIELD."
350 (funcall (custom-property (custom-field-custom field) 'extract)
353 (defun custom-field-validate (custom field)
354 "Validate CUSTOM's value in FIELD.
355 Return nil if valid, otherwise return a cons-cell where the car is the
356 position of the error, and the cdr is a text describing the error."
359 (funcall (custom-property custom 'validate) custom field)))
363 ;; This section defines the public functions for manipulating the
364 ;; FIELD datatype. The FIELD instance hold information about a
365 ;; specific editing field in the customization buffer.
367 ;; Each FIELD can be seen as an instanciation of a CUSTOM.
369 (defun custom-field-create (custom value)
370 "Create a field structure of type CUSTOM containing VALUE.
372 A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
373 CUSTOM defines the type of the field,
374 VALUE is the current value of the field,
375 ORIGINAL is the original value when created, and
376 START and END are markers to the start and end of the field."
377 (vector custom value custom-nil nil nil))
379 (defun custom-field-custom (field)
380 "Return the `custom' attribute of FIELD."
383 (defun custom-field-value (field)
384 "Return the `value' attribute of FIELD."
387 (defun custom-field-original (field)
388 "Return the `original' attribute of FIELD."
391 (defun custom-field-start (field)
392 "Return the `start' attribute of FIELD."
395 (defun custom-field-end (field)
396 "Return the `end' attribute of FIELD."
399 (defun custom-field-value-set (field value)
400 "Set the `value' attribute of FIELD to VALUE."
401 (aset field 1 value))
403 (defun custom-field-original-set (field original)
404 "Set the `original' attribute of FIELD to ORIGINAL."
405 (aset field 2 original))
407 (defun custom-field-move (field start end)
408 "Set the `start'and `end' attributes of FIELD to START and END."
409 (set-marker (or (aref field 3) (aset field 3 (make-marker))) start)
410 (set-marker (or (aref field 4) (aset field 4 (make-marker))) end))
412 (defun custom-field-query (field)
413 "Query user for content of current field."
414 (funcall (custom-property (custom-field-custom field) 'query) field))
416 (defun custom-field-accept (field value &optional original)
418 If optional ORIGINAL is non-nil, concider VALUE for the original value."
419 (funcall (custom-property (custom-field-custom field) 'accept)
420 field value original))
424 ;; The following functions defines type specific actions.
426 (defun custom-repeat-accept (field value &optional original)
427 "Enter content of editing FIELD."
428 (let ((values (copy-sequence (custom-field-value field)))
429 (all (custom-field-value field))
430 (start (custom-field-start field))
433 (custom-field-original-set field value))
435 (setq new (car value)
438 ;; Change existing field.
439 (setq current (car values)
441 ;; Insert new field if series has grown.
443 (setq current (custom-repeat-insert-entry field))
444 (setq all (custom-insert-before all nil current))
445 (custom-field-value-set field all))
446 (custom-field-accept current new original))
447 (while (consp values)
448 ;; Delete old field if series has scrunk.
449 (setq current (car values)
451 (let ((pos (custom-field-start current))
454 (setq pos (previous-single-property-change pos 'custom-data))
456 (setq data (get-text-property pos 'custom-data))
457 (or (and (arrayp data)
459 (eq current (aref data 1)))
461 (custom-repeat-delete data)))))
463 (defun custom-repeat-insert (custom level)
464 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
465 (let* ((field (custom-field-create custom nil))
466 (add-tag (custom-property custom 'add-tag))
467 (del-tag (custom-property custom 'del-tag))
468 (start (make-marker))
469 (data (vector field nil start nil)))
470 (custom-text-insert "\n")
472 (custom-tag-insert add-tag 'custom-repeat-add data)
473 (set-marker start pos))
474 (custom-field-move field start (point))
475 (custom-documentation-insert custom)
478 (defun custom-repeat-insert-entry (repeat)
479 "Insert entry at point in the REPEAT field."
480 (let* ((inhibit-point-motion-hooks t)
481 (inhibit-read-only t)
482 (before-change-function nil)
483 (after-change-function nil)
484 (custom (custom-field-custom repeat))
485 (add-tag (custom-property custom 'add-tag))
486 (del-tag (custom-property custom 'del-tag))
487 (start (make-marker))
489 (data (vector repeat nil start end))
491 (insert-before-markers "\n")
493 (set-marker start (point))
494 (custom-text-insert " ")
495 (aset data 1 (setq field (custom-insert (custom-data custom) nil)))
496 (custom-text-insert " ")
497 (set-marker end (point))
499 (custom-tag-insert add-tag 'custom-repeat-add data)
500 (custom-text-insert " ")
501 (custom-tag-insert del-tag 'custom-repeat-delete data)
505 (defun custom-repeat-add (data)
507 (let ((parent (aref data 0))
508 (field (aref data 1))
512 (setq new (custom-repeat-insert-entry parent))
513 (custom-field-value-set parent
514 (custom-insert-before (custom-field-value parent)
517 (defun custom-repeat-delete (data)
519 (let ((inhibit-point-motion-hooks t)
520 (inhibit-read-only t)
521 (before-change-function nil)
522 (after-change-function nil)
523 (parent (aref data 0))
524 (field (aref data 1)))
525 (delete-region (aref data 2) (1+ (aref data 3)))
526 (custom-field-untouch (aref data 1))
527 (custom-field-value-set parent
528 (delq field (custom-field-value parent)))))
530 (defun custom-repeat-match (custom values)
531 "Match CUSTOM with VALUES."
532 (let* ((child (custom-data custom))
533 (match (custom-match child values))
535 (while (not (eq (car match) custom-nil))
536 (setq matches (cons (car match) matches)
538 match (custom-match child values)))
539 (cons (nreverse matches) values)))
541 (defun custom-repeat-extract (custom field)
542 "Extract list of childrens values."
543 (let ((values (custom-field-value field))
544 (data (custom-data custom))
546 (if (eq values custom-nil)
549 ;; (message "Before values = %S result = %S" values result)
550 (setq result (append result (custom-field-extract data (car values)))
552 ;; (message "After values = %S result = %S" values result)
556 (defun custom-repeat-validate (custom field)
558 (let ((values (custom-field-value field))
559 (data (custom-data custom))
561 (if (eq values custom-nil)
562 (setq result (cons (custom-field-start field) "Uninitialized list")))
563 (while (and values (not result))
564 (setq result (custom-field-validate data (car values))
565 values (cdr values)))
568 (defun custom-list-extract (custom field)
569 "Extract list of childrens values."
570 (let ((values (custom-field-value field))
571 (data (custom-data custom))
573 (custom-assert '(eq (length values) (length data)))
575 (setq result (append result
576 (custom-field-extract (car data) (car values)))
578 values (cdr values)))
579 (custom-assert '(null data))
582 (defun custom-list-validate (custom field)
584 (let ((values (custom-field-value field))
585 (data (custom-data custom))
587 (if (eq values custom-nil)
588 (setq result (cons (custom-field-start field) "Uninitialized list"))
589 (custom-assert '(eq (length values) (length data))))
590 (while (and values (not result))
591 (setq result (custom-field-validate (car data) (car values))
593 values (cdr values)))
596 (defun custom-group-accept (field value &optional original)
597 "Enter content of editing FIELD with VALUE."
598 (let ((values (custom-field-value field))
601 (custom-field-original-set field value))
603 (setq current (car values)
606 (let* ((custom (custom-field-custom current))
607 (match (custom-match custom value)))
608 (setq value (cdr match))
609 (custom-field-accept current (car match) original))))))
611 (defun custom-group-insert (custom level)
612 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
613 (let* ((field (custom-field-create custom nil))
616 (compact (custom-compact custom))
617 (tag (custom-tag custom)))
618 (if tag (custom-tag-insert tag field))
619 (or compact (custom-documentation-insert custom))
620 (or compact (custom-text-insert "\n"))
621 (let ((data (custom-data custom)))
623 (setq fields (cons (custom-insert (car data) (if level (1+ level)))
625 (setq data (cdr data))
626 (if data (custom-text-insert (if compact " " "\n")))))
627 (if compact (custom-documentation-insert custom))
628 (custom-field-value-set field (nreverse fields))
629 (custom-field-move field from (point))
632 (defun custom-choice-insert (custom level)
633 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
634 (let* ((field (custom-field-create custom nil))
636 (tag (custom-tag custom)))
637 (custom-text-insert "lars er en nisse")
638 (custom-field-move field from (point))
639 (custom-documentation-insert custom)
640 (custom-field-reset field)
643 (defun custom-choice-accept (field value &optional original)
644 "Reset content of editing FIELD."
645 (let ((custom (custom-field-custom field))
646 (start (custom-field-start field))
647 (end (custom-field-end field))
648 (inhibit-read-only t)
649 (before-change-function nil)
650 (after-change-function nil)
653 (setq custom-modified-list (delq field custom-modified-list))
654 (custom-field-original-set field value))
655 ((equal value (custom-field-original field))
656 (setq custom-modified-list (delq field custom-modified-list)))
658 (add-to-list 'custom-modified-list field)))
659 (custom-field-untouch (custom-field-value field))
660 (delete-region start end)
663 (insert-before-markers " ")
665 (set-text-properties (point) (1+ (point))
668 (custom-tag-insert (custom-tag custom) field)
669 (custom-text-insert ": ")
670 (let ((data (custom-data custom))
672 (while (and data (not found))
673 (if (not (custom-valid (car data) value))
674 (setq data (cdr data))
675 (setq found (custom-insert (car data) nil))
680 found (custom-insert (custom-property custom 'none) nil))
681 (add-text-properties begin (point)
682 (list 'rear-nonsticky t
683 'face custom-field-uninitialized-face)))
684 (custom-field-accept found value original)
685 (custom-field-value-set field found)
686 (custom-field-move field from end))))
688 (defun custom-choice-extract (custom field)
689 "Extract childs value."
690 (let ((value (custom-field-value field)))
691 (custom-field-extract (custom-field-custom value) value)))
693 (defun custom-choice-validate (custom field)
694 "Validate childs value."
695 (let ((value (custom-field-value field))
696 (custom (custom-field-custom field)))
697 (if (or (eq value custom-nil)
698 (eq (custom-field-custom value) (custom-property custom 'none)))
699 (cons (custom-field-start field) "Make a choice")
700 (custom-field-validate (custom-field-custom value) value))))
702 (defun custom-choice-query (field)
704 (let* ((custom (custom-field-custom field))
705 (default (custom-tag-or-type
706 (custom-field-custom (custom-field-value field))))
707 (tag (custom-tag-or-type custom))
708 (data (custom-data custom))
711 (setq current (car data)
713 (setq alist (cons (cons (custom-tag-or-type current) current) alist)))
714 (let ((answer (if (listp last-input-event)
715 (x-popup-menu last-input-event
716 (list tag (cons "" (reverse alist))))
717 (let ((choice (completing-read (concat tag " (default "
720 (if (or (null choice) (string-equal choice ""))
721 (setq choice default))
722 (cdr (assoc choice alist))))))
724 (custom-field-accept field (custom-default answer))))))
726 (defun custom-file-query (field)
727 "Prompt for a file name"
728 (let* ((value (custom-field-value field))
729 (custom (custom-field-custom field))
730 (valid (custom-valid custom value))
731 (directory (custom-property custom 'directory))
732 (default (and (not valid)
733 (custom-property custom 'default-file)))
734 (tag (custom-tag custom))
736 (concat tag " (" default "): ")
738 (custom-field-accept field
739 (if (custom-valid custom value)
740 (read-file-name prompt
741 (if (file-name-absolute-p value)
745 (read-file-name prompt directory default)))))
747 (defun custom-const-insert (custom level)
748 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
749 (let ((field (custom-field-create custom custom-nil))
751 (custom-text-insert (custom-tag custom))
752 (custom-documentation-insert custom)
753 (custom-field-move field from (point))
756 (defun custom-const-valid (custom value)
757 "Non-nil if CUSTOM can legally have the value VALUE."
758 (equal (custom-default custom) value))
760 (defun custom-integer-read (custom integer)
761 "Read from CUSTOM an INTEGER."
762 (string-to-int (save-match-data
763 (custom-strip-padding integer (custom-padding custom)))))
765 (defun custom-integer-write (custom integer)
766 "Write CUSTOM INTEGER as string."
767 (int-to-string integer))
769 (defun custom-string-read (custom string)
770 "Read string by ignoring trailing padding characters."
771 (let ((last (length string))
772 (padding (custom-padding custom)))
773 (while (and (> last 0)
774 (eq (aref string (1- last)) padding))
775 (setq last (1- last)))
776 (substring string 0 last)))
778 (defun custom-string-write (custom string)
782 (defun custom-button-insert (custom level)
783 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
784 (custom-tag-insert (concat "[" (custom-tag custom) "]")
785 (custom-property custom 'query))
786 (custom-documentation-insert custom)
789 (defun custom-default-insert (custom level)
790 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
791 (let ((field (custom-field-create custom custom-nil))
792 (tag (custom-tag custom)))
795 (custom-tag-insert tag field)
796 (custom-text-insert ": "))
797 (custom-field-insert field)
798 (custom-documentation-insert custom)
801 (defun custom-default-accept (field value &optional original)
802 "Enter into FIELD the value VALUE."
804 (custom-field-original-set field value))
805 (custom-field-value-set field value)
806 (custom-field-update field))
808 (defun custom-default-reset (field)
809 "Reset content of editing FIELD."
810 (custom-field-accept field (custom-field-original field) t))
812 (defun custom-default-query (field)
814 (let* ((custom (custom-field-custom field))
815 (value (custom-field-value field))
816 (initial (custom-write custom value))
817 (prompt (concat (custom-tag-or-type custom) ": ")))
818 (custom-field-accept field
820 (if (custom-valid custom value)
821 (read-string prompt (cons initial 1))
822 (read-string prompt))))))
824 (defun custom-default-match (custom values)
825 "Match CUSTOM with VALUES."
828 (defun custom-default-extract (custom field)
829 "Extract CUSTOM's content in FIELD."
830 (list (custom-field-value field)))
832 (defun custom-default-validate (custom field)
834 (let ((value (custom-field-value field))
835 (start (custom-field-start field)))
836 (cond ((eq value custom-nil)
837 (cons (custom-field-start field) "Uninitialized field"))
838 ((custom-valid custom value)
841 (cons start "Wrong type")))))
845 ;; Public functions to create a customization buffer and to insert
846 ;; various forms of text, fields, and buttons in it.
848 (defun custom-buffer-create (name &optional custom types set get)
849 "Create a customization buffer named NAME.
850 If the optional argument CUSTOM is non-nil, use that as the custom declaration.
851 If the optional argument TYPES is non-nil, use that as the local types.
852 If the optional argument SET is non-nil, use that to set external data.
853 If the optional argument GET is non-nil, use that to get external data."
854 (switch-to-buffer name)
855 (buffer-disable-undo)
857 (setq custom-local-type-properties types)
860 (make-local-variable 'custom-data)
861 (setq custom-data custom))
864 (make-local-variable 'custom-external-set)
865 (setq custom-external-set set))
868 (make-local-variable 'custom-external)
869 (setq custom-external get))
870 (let ((inhibit-point-motion-hooks t)
871 (before-change-function nil)
872 (after-change-function nil))
875 (goto-char (point-min))
876 (custom-text-insert "This is a customization buffer.\n")
877 (custom-help-insert "\n")
878 (custom-help-button 'custom-forward-field)
879 (custom-help-button 'custom-enter-value)
880 (custom-help-button 'custom-field-reset)
881 (custom-help-button 'custom-field-apply)
882 (custom-help-button 'custom-toggle-documentation)
883 (custom-help-insert "\nClick mouse-2 on any button to activate it.\n")
884 (custom-insert custom 1)
885 (goto-char (point-min))))
887 (defun custom-insert (custom level)
888 "Insert custom declaration CUSTOM in current buffer at level LEVEL."
891 (custom-text-insert custom)
893 (and level (null (custom-property custom 'header))
896 (custom-text-insert (concat "\n" (make-string level ?*) " ")))
897 (let ((field (funcall (custom-property custom 'insert) custom level)))
898 (custom-name-enter (custom-name custom) field)
901 (defun custom-text-insert (text)
902 "Insert TEXT in current buffer."
905 (defun custom-tag-insert (tag field &optional data)
906 "Insert TAG for FIELD in current buffer."
907 (let ((from (point)))
909 (set-text-properties from (point)
910 (list 'category custom-button-properties
913 (add-text-properties from (point) (list 'custom-data data)))))
915 (defun custom-documentation-insert (custom &rest ignore)
916 "Insert documentation from CUSTOM in current buffer."
917 (let ((doc (custom-documentation custom)))
920 (custom-help-insert "\n" doc))))
922 (defun custom-help-insert (&rest args)
923 "Insert ARGS as documentation text."
924 (let ((from (point)))
926 (set-text-properties from (point)
927 (list 'category custom-documentation-properties))))
929 (defun custom-help-button (command)
930 "Describe how to execute COMMAND."
931 (let ((from (point)))
932 (insert "`" (key-description (where-is-internal command nil t)) "'")
933 (set-text-properties from (point)
934 (list 'category custom-documentation-properties
935 'face custom-button-face
936 'mouse-face custom-mouse-face
937 'custom-tag command)))
938 (custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
942 ;; The Customization major mode and interactive commands.
944 (defvar custom-mode-map nil
945 "Keymap for Custum Mode.")
948 (setq custom-mode-map (make-sparse-keymap))
949 (define-key custom-mode-map [ mouse-2 ] 'custom-push-button)
950 (define-key custom-mode-map "\t" 'custom-forward-field)
951 (define-key custom-mode-map "\r" 'custom-enter-value)
952 (define-key custom-mode-map "\C-k" 'custom-kill-line)
953 (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
954 (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
955 (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
956 (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
957 (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
959 ;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
960 ;; forward-field, C-b backward-field, C-n next-field, C-p
961 ;; previous-field, ? describe-field.
963 (defun custom-mode ()
964 "Major mode for doing customizations.
967 (kill-all-local-variables)
968 (setq major-mode 'custom-mode
970 (use-local-map custom-mode-map)
971 (make-local-variable 'before-change-function)
972 (setq before-change-function 'custom-before-change)
973 (make-local-variable 'after-change-function)
974 (setq after-change-function 'custom-after-change)
975 (if (not (fboundp 'make-local-hook))
976 ;; Emacs 19.28 and earlier.
977 (add-hook 'post-command-hook 'custom-post-command nil)
979 (make-local-hook 'post-command-hook)
980 (add-hook 'post-command-hook 'custom-post-command nil t)))
982 (defun custom-forward-field (arg)
983 "Move point to the next field or button.
984 With optional ARG, move across that many fields."
988 (let ((next (if (get-text-property (point) 'custom-tag)
989 (next-single-property-change (point) 'custom-tag)
991 (setq next (or (next-single-property-change next 'custom-tag)
992 (next-single-property-change (point-min) 'custom-tag)))
995 (error "No customization fields in this buffer.")))))
997 (defun custom-toggle-documentation (&optional arg)
998 "Toggle display of documentation text.
999 If the optional argument is non-nil, show text iff the argument is positive."
1001 (let ((hide (or (and (null arg)
1002 (null (get custom-documentation-properties 'invisible)))
1003 (<= (prefix-numeric-value arg) 0))))
1004 (put custom-documentation-properties 'invisible hide)
1005 (put custom-documentation-properties intangible hide))
1008 (defun custom-enter-value (field data)
1009 "Enter value for current customization field or push button."
1010 (interactive (list (get-text-property (point) 'custom-tag)
1011 (get-text-property (point) 'custom-data)))
1013 (funcall field data))
1014 ((eq field 'custom-enter-value)
1015 (error "Don't be silly"))
1016 ((and (symbolp field) (fboundp field))
1017 (call-interactively field))
1019 (custom-field-query field))
1021 (message "Nothing to enter here"))))
1023 (defun custom-kill-line ()
1024 "Kill to end of field or end of line, whichever is first."
1026 (let ((field (get-text-property (point) 'custom-field))
1027 (newline (save-excursion (search-forward "\n")))
1028 (next (next-single-property-change (point) 'custom-field)))
1029 (if (and field (> newline next))
1030 (kill-region (point) next)
1031 (call-interactively 'kill-line))))
1033 (defun custom-push-button (event)
1034 "Activate button below mouse pointer."
1036 (set-buffer (window-buffer (posn-window (event-start event))))
1037 (let* ((pos (posn-point (event-start event)))
1038 (field (get-text-property pos 'custom-field))
1039 (tag (get-text-property pos 'custom-tag))
1040 (data (get-text-property pos 'custom-data)))
1043 ((and (symbolp tag) (fboundp tag))
1044 (call-interactively tag))
1046 (call-interactively (lookup-key global-map (this-command-keys))))
1048 (custom-enter-value tag data))
1050 (error "Nothing to click on here.")))))
1052 (defun custom-reset-all ()
1053 "Undo any changes since the last apply in all fields."
1054 (interactive (and custom-modified-list
1055 (not (y-or-n-p "Discard all changes? "))
1056 (error "Reset aborted")))
1057 (let ((all custom-name-fields)
1060 (setq current (car all)
1064 (custom-field-reset field))))
1066 (defun custom-field-reset (field)
1067 "Undo any changes in FIELD since the last apply."
1068 (interactive (list (or (get-text-property (point) 'custom-field)
1069 (get-text-property (point) 'custom-tag))))
1070 (if (not (arrayp field))
1071 (error "No field to reset here"))
1072 (let* ((custom (custom-field-custom field))
1073 (name (custom-name custom)))
1076 (custom-field-original-set field (custom-external name)))
1077 (funcall (custom-property custom 'reset) field))))
1079 (defun custom-apply-all ()
1080 "Apply any changes since the last reset in all fields."
1081 (interactive (or custom-modified-list
1082 (error "No changes to apply.")))
1083 (let ((all custom-name-fields)
1086 (setq field (cdr (car all))
1088 (let ((error (custom-field-validate (custom-field-custom field) field)))
1091 (goto-char (car error))
1092 (error (cdr error))))))
1093 (let ((all custom-name-fields)
1096 (setq field (cdr (car all))
1098 (custom-field-apply field))))
1100 (defun custom-field-apply (field)
1101 "Apply any changes in FIELD since the last apply."
1102 (interactive (list (or (get-text-property (point) 'custom-field)
1103 (get-text-property (point) 'custom-tag))))
1104 (if (not (arrayp field))
1105 (error "No field to reset here"))
1106 (let* ((custom (custom-field-custom field))
1107 (name (custom-name custom))
1108 (error (custom-field-validate custom field)))
1110 (error "This field cannot be applied alone"))
1112 (error (cdr error)))
1114 (custom-external-set name (car (custom-field-extract custom field)))
1115 (custom-field-reset field)))))
1117 (defun custom-toggle-hide (&rest ignore)
1118 "Hide or show entry."
1120 (error "This button is not yet implemented"))
1124 ;; Various internal functions for implementing the direct editing of
1125 ;; fields in the customization buffer.
1127 (defvar custom-modified-list nil)
1128 ;; List of modified fields.
1129 (make-variable-buffer-local 'custom-modified-list)
1131 (defun custom-field-untouch (field)
1132 ;; Remove FIELD and its children from `custom-modified-list'.
1133 (setq custom-modified-list (delq field custom-modified-list))
1135 (let ((value (custom-field-value field)))
1136 (cond ((arrayp value)
1137 (custom-field-untouch value))
1139 (mapcar 'custom-field-untouch value))))))
1142 (defun custom-field-insert (field)
1143 ;; Insert editing FIELD in current buffer.
1144 (let ((from (point))
1145 (custom (custom-field-custom field))
1146 (value (custom-field-value field)))
1147 (insert (custom-write custom value))
1148 (insert-char (custom-padding custom)
1149 (- (custom-width custom) (- (point) from)))
1150 (custom-field-move field from (point))
1151 (set-text-properties
1153 (list 'custom-field field
1155 'face (custom-field-face field)
1158 (defun custom-field-update (field)
1159 ;; Update the content of FIELD.
1160 (let ((inhibit-point-motion-hooks t)
1161 (before-change-function nil)
1162 (after-change-function nil)
1163 (start (custom-field-start field))
1164 (end (custom-field-end field))
1166 ;; Keep track of how many modified fields we have.
1167 (cond ((equal (custom-field-value field) (custom-field-original field))
1168 (setq custom-modified-list (delq field custom-modified-list)))
1169 ((memq field custom-modified-list))
1171 (setq custom-modified-list (cons field custom-modified-list))))
1172 ;; Update the field.
1174 (insert-before-markers " ")
1175 (delete-region start (1- end))
1177 (custom-field-insert field)
1183 (custom-field-enter field))))
1185 (defun custom-field-read (field)
1186 ;; Read the screen content of FIELD.
1187 (custom-read (custom-field-custom field)
1188 (buffer-substring-no-properties (custom-field-start field)
1189 (custom-field-end field))))
1191 (defun custom-field-face (field)
1192 ;; Face used for an inactive field FIELD.
1193 (let ((value (custom-field-value field)))
1194 (cond ((eq value custom-nil)
1195 custom-field-uninitialized-face)
1196 ((not (custom-valid (custom-field-custom field) value))
1197 custom-field-invalid-face)
1198 ((not (equal (custom-field-original field) value))
1199 custom-field-modified-face)
1201 custom-field-face))))
1203 (defun custom-field-leave (field)
1204 ;; Deactivate FIELD.
1205 (let ((before-change-function nil)
1206 (after-change-function nil))
1207 (put-text-property (custom-field-start field) (custom-field-end field)
1208 'face (custom-field-face field))))
1210 (defun custom-field-enter (field)
1212 (let* ((start (custom-field-start field))
1213 (end (custom-field-end field))
1214 (custom (custom-field-custom field))
1215 (padding (custom-padding custom))
1216 (allow (custom-allow-padding custom))
1217 (before-change-function nil)
1218 (after-change-function nil))
1219 (or (and (eq this-command 'self-insert-command)
1222 (while (and (< start pos)
1223 (eq (char-after (1- pos)) padding))
1224 (setq pos (1- pos)))
1227 (put-text-property start end 'face custom-field-active-face)))
1229 (defvar custom-field-last nil)
1230 ;; Last field containing point.
1231 (make-variable-buffer-local 'custom-field-last)
1233 (defun custom-post-command ()
1234 ;; Keep track of their active field.
1235 (if (not (eq major-mode 'custom-mode))
1236 ;; BUG: Should have been local!
1238 (let ((field (custom-field-property (point))))
1239 (if (eq field custom-field-last)
1241 (if custom-field-last
1242 (custom-field-leave custom-field-last))
1244 (custom-field-enter field))
1245 (setq custom-field-last field)))
1246 (set-buffer-modified-p custom-modified-list)))
1248 (defvar custom-field-was nil)
1249 ;; The custom data before the change.
1250 (make-variable-buffer-local 'custom-field-was)
1252 (defun custom-before-change (begin end)
1253 ;; Check that we the modification is allowed.
1254 (if (not (eq major-mode 'custom-mode))
1255 (message "Aargh! Why is custom-before-change called here?")
1256 (let ((from (custom-field-property begin))
1257 (to (custom-field-property end)))
1258 (cond ((or (null from) (null to))
1259 (error "You can only modify the fields"))
1261 (error "Changes must be limited to a single field."))
1263 (setq custom-field-was from))))))
1265 (defun custom-after-change (begin end length)
1266 ;; Keep track of field content.
1267 (if (not (eq major-mode 'custom-mode))
1268 (message "Aargh! Why is custom-after-change called here?")
1269 (let ((field custom-field-was))
1270 (custom-assert '(prog1 field (setq custom-field-was nil)))
1271 ;; Prevent mixing fields properties.
1272 (put-text-property begin end 'custom-field field)
1273 ;; Update the field after modification.
1274 (if (eq (custom-field-property begin) field)
1275 (let ((field-end (custom-field-end field)))
1276 (if (> end field-end)
1277 (set-marker field-end end))
1278 (custom-field-value-set field (custom-field-read field))
1279 (custom-field-update field))
1280 ;; We deleted the entire field, reinsert it.
1281 (custom-assert '(eq begin end))
1284 (custom-field-value-set field
1285 (custom-read (custom-field-custom field) ""))
1286 (custom-field-insert field))))))
1288 (defun custom-field-property (pos)
1289 ;; The `custom-field' text property valid for POS.
1290 (or (get-text-property pos 'custom-field)
1291 (and (not (eq pos (point-min)))
1292 (get-text-property (1- pos) 'custom-field))))
1294 ;;; Generic Utilities:
1296 ;; Some utility functions that are not really specific to custom.
1298 (defun custom-assert (expr)
1299 "Assert that EXPR evaluates to non-nil at this point"
1301 (error "Assertion failed: %S" expr)))
1303 (defun custom-first-line (string)
1304 "Return the part of STRING before the first newline."
1306 (len (length string)))
1307 (while (and (< pos len) (not (eq (aref string pos) ?\n)))
1308 (setq pos (1+ pos)))
1311 (substring string 0 pos))))
1313 (defun custom-insert-before (list old new)
1314 "In LIST insert before OLD a NEW element."
1318 (nconc list (list new)))
1319 ((eq old (car list))
1323 (while (not (eq old (car (cdr list))))
1324 (setq list (cdr list))
1325 (custom-assert '(cdr list)))
1326 (setcdr list (cons new (cdr list))))
1329 (defun custom-strip-padding (string padding)
1330 "Remove padding from STRING."
1331 (let ((regexp (concat (regexp-quote (char-to-string padding)) "+")))
1332 (while (string-match regexp string)
1333 (setq string (concat (substring string 0 (match-beginning 0))
1334 (substring string (match-end 0))))))
1339 ;;; custom.el ends here