| blob | e9657538ecfdb6d57ec630f0c7af2ec5de640283 |
1 ;;; custom.el --- User friendly customization support.
3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
5 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
6 ;; Keywords: help
7 ;; Version: 0.5
9 ;; This file is part of GNU Emacs.
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.
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.
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.
26 ;;; Commentary:
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 ;;
36 ;; The intent is that authors of emacs lisp packages declare the
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.
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.
67 ;; - Use W3 for variable documentation.
69 ;;; Code:
71 ;;; Compatibility:
74 ;; Introduced in Emacs 19.29.
76 "Return the text from BEG to END, without text properties, as a string."
79 string)))
82 ;; Introduced in Emacs 19.29.
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."
94 ;; Introduced in Emacs 19.29.
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."
105 plist nil)
107 result)))
110 ;; Introduced in Emacs 19.29.
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."
131 plist)))
134 ;; Introduced in Emacs 19.29.
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."
147 ;; Introduced in Emacs 19.29.
149 "Return t if X is a face name or an internal face vector."
154 t)))
156 ;; XEmacs and Emacs 19.29 facep does different things.
162 ()
163 ;; No underline face in XEmacs 19.12.
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!
175 ;; Missing in XEmacs 19.12.
186 ;; Missing in Emacs 19.29.
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."
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.
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."
223 x-bitmap-file-path))))
245 bold-p italic-p underline-p)))
258 ;; We can't easily check for a working intangible.
268 'end-open
273 'front-closed
278 'highlight
282 ;; Put it in the Help menu, if possible.
284 ;; XEmacs (disabled because it doesn't work)
287 ;; Emacs 19.28 and earlier
290 ;; Emacs 19.29 and later
294 ;; XEmacs popup-menu stolen from w3.el.
296 "My hacked up function to do a blocking popup menu..."
298 event menu)
313 nil)
317 nil)
322 ;;; Categories:
323 ;;
324 ;; XEmacs use inheritable extents for the same purpose as Emacs uses
325 ;; the category text property.
329 ;; XEmacs categories.
335 "In CATEGORY set PROPERTY to VALUE."
339 "In CATEGORY get PROPERTY."
343 "Make text between FROM and TWO have category CATEGORY."
347 ;; Emacs categories.
349 "Create a text property category named NAME."
353 "In CATEGORY set PROPERTY to VALUE."
357 "In CATEGORY get PROPERTY."
361 "Make text between FROM and TWO have category CATEGORY."
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.
377 "Get the external value associated with NAME."
381 "Set the external value associated with NAME to VALUE."
389 "Associate NAME with FIELD."
391 ()
396 "The editing field associated with NAME."
400 "The value currently displayed for NAME in the customization buffer."
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
415 ;; CUSTOM instances are part of two hierarchies, the first is the
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
418 ;; `custom-data'. The second hierarchy is a `is-a' type hierarchy
419 ;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
420 ;; property and `custom-type-properties'.
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
451 "The global customization information.
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."
467 ;; See `custom-match'.
481 ;; A cons-cell.
489 ;; A lisp list.
495 ;; See `custom-match'.
510 ;; Booleans.
518 ;; On/Off/Default.
529 ;; See `custom-match'.
539 ;; A `const' only matches a single lisp value.
546 ;; A variable containing a face.
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.
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
637 " "
641 " "
647 nil nil nil))
654 ;; A string containing a file or directory name.
659 ;; Any lisp expression.
665 ;; A lisp symbol.
669 ;; A lisp integer.
673 ;; A lisp string.
679 ;; Push me.
685 ;; A documentation only entry with no value.
721 "Alist of default properties for type symbols.
725 "Local type properties.
737 ;; Bad, ugly, and horrible kludge.
740 "Extract from CUSTOM property PROPERTY."
743 ;; Look in superclass.
752 "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass."
755 ;; Look in superclass.
764 "Set CUSTOM PROPERTY to VALUE by side effect.
765 CUSTOM must have at least one property already."
772 "Extract `type' from CUSTOM."
776 "Extract `name' from CUSTOM."
780 "Extract `tag' from CUSTOM."
784 "Extract `face-tag' from CUSTOM."
788 "Extract `prompt' from CUSTOM.
789 If none exist, default to `tag' or, failing that, `type'."
795 "Extract `default' from CUSTOM."
802 "Extract the `data' from CUSTOM."
806 "Extract `doc' from CUSTOM."
810 "Extract `width' from CUSTOM."
814 "Extract `compact' from CUSTOM."
818 "Extract `padding' from CUSTOM."
822 "Non-nil if CUSTOM may validly be set to VALUE."
827 "Import CUSTOM VALUE from external variable.
829 This function change VALUE into a form that makes it easier to edit
830 internally. What the internal form is exactly depends on CUSTOM.
831 The internal form is returned."
837 "Return non-nil if CUSTOM's VALUE needs to be evaluated."
841 "Quote CUSTOM's VALUE if necessary."
845 "Convert CUSTOM VALUE to a string."
854 "Convert CUSTOM field content STRING into lisp."
860 "Match CUSTOM with a list of VALUES.
862 Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
863 and the cdr is the remaining VALUES.
865 A CUSTOM is actually a regular expression over the alphabet of lisp
866 types. Most CUSTOM types are just doing a literal match, e.g. the
867 `symbol' type matches any lisp symbol. The exceptions are:
869 group: which corresponds to a `(' and `)' group in a regular expression.
870 choice: which corresponds to a group of `|' in a regular expression.
871 repeat: which corresponds to a `*' in a regular expression.
872 optional: which corresponds to a `?', and isn't implemented yet."
874 ;; Nothing matches the uninitialized or empty list.
879 "Initialize `doc' and `default' attributes of CUSTOM."
883 "Find child in CUSTOM with `tag' TAG."
887 "Find decedent of CUSTOM by looking through PATH."
889 custom
893 "Extract CUSTOM's value in FIELD."
895 nil
897 custom field)))
900 "Validate CUSTOM's value in FIELD.
901 Return nil if valid, otherwise return a cons-cell where the car is the
902 position of the error, and the cdr is a text describing the error."
904 nil
907 ;;; Field Functions:
908 ;;
909 ;; This section defines the public functions for manipulating the
910 ;; FIELD datatype. The FIELD instance hold information about a
911 ;; specific editing field in the customization buffer.
912 ;;
913 ;; Each FIELD can be seen as an instantiation of a CUSTOM.
916 ;; Last field containing point.
920 ;; List of modified fields.
924 "Create a field structure of type CUSTOM containing VALUE.
926 A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
927 CUSTOM defines the type of the field,
928 VALUE is the current value of the field,
929 ORIGINAL is the original value when created, and
930 START and END are markers to the start and end of the field."
934 "Return the `custom' attribute of FIELD."
938 "Return the `value' attribute of FIELD."
942 "Return the `original' attribute of FIELD."
946 "Return the `start' attribute of FIELD."
950 "Return the `end' attribute of FIELD."
954 "Set the `value' attribute of FIELD to VALUE."
958 "Set the `original' attribute of FIELD to ORIGINAL."
962 "Set the `start'and `end' attributes of FIELD to START and END."
967 "Query user for content of current field."
971 "Store a new value into field FIELD, taking it from VALUE.
972 If optional ORIGINAL is non-nil, consider VALUE for the original value."
975 field value original)))
978 "The face used for highlighting FIELD."
981 nil
986 "Update the screen appearance of FIELD to correspond with the field's value."
989 nil
992 ;;; Types:
993 ;;
994 ;; The following functions defines type specific actions.
997 "Non-nil if CUSTOM's VALUE needs to be evaluated."
999 nil
1003 value))))
1006 "A list of CUSTOM's VALUEs quoted."
1009 value))))
1013 "Modify CUSTOM's VALUE to match internal expectations."
1016 value))))
1019 "Store a new value into field FIELD, taking it from VALUE."
1023 current new)
1030 ;; Change existing field.
1033 ;; Insert new field if series has grown.
1040 ;; Delete old field if series has scrunk.
1044 data)
1056 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1068 field))
1071 "Insert entry at point in the REPEAT field."
1082 field)
1096 field))
1099 "Add list entry."
1103 new)
1108 field new))))
1111 "Delete list entry."
1124 "Match CUSTOM with VALUES."
1127 matches)
1135 "Extract list of children's values."
1138 result)
1140 ()
1144 result))
1147 "Validate children."
1150 result)
1156 result))
1159 "Store a new value into field FIELD, taking it from VALUE."
1163 "Non-nil if CUSTOM's VALUE needs to be evaluated."
1167 "Modify CUSTOM's VALUE to match internal expectations."
1174 "Quote CUSTOM's VALUE if necessary."
1182 "Extract cons of children's values."
1185 result)
1196 "Quote CUSTOM's VALUE if necessary."
1203 "Extract list of children's values."
1206 result)
1217 "Validate children."
1220 result)
1228 result))
1231 "Non-nil if CUSTOM's VALUE needs to be evaluated."
1240 found))
1243 "A list of CUSTOM's VALUE members, quoted."
1247 ()
1254 "Modify CUSTOM's VALUE to match internal expectations."
1258 ()
1265 "Initialize `doc' and `default' entries in CUSTOM."
1271 "Reset `value' in FIELD to `original'."
1279 "Reset `value' in FIELD to `original'."
1287 "Reset `value' in FIELD to `default'."
1295 "Find child in CUSTOM with `tag' TAG."
1305 "Store a new value into field FIELD, taking it from VALUE."
1310 current)
1326 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1328 fields hidden
1340 fields))
1350 field))
1353 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1360 field))
1363 "Store a new value into field FIELD, taking it from VALUE."
1370 from)
1388 found begin)
1395 ()
1408 "Extract child's value."
1413 "Validate child's value."
1422 "Choose a child."
1428 current alist)
1441 last-input-event tag
1443 alist)))
1449 " (default "
1450 default
1452 alist nil t)))
1460 "Prompt for a file name"
1475 ""
1476 directory)
1477 default nil value)
1481 "Return non-nil if CUSTOM's VALUE needs to be evaluated."
1485 "Modify CUSTOM's VALUE to match internal expectations."
1489 name)
1497 value))))
1500 "Lookup or create a face with specified attributes.
1501 FG BG STIPPLE BOLD ITALIC UNDERLINE"
1506 bold italic underline))))
1509 ()
1515 bold italic underline))
1516 name))
1519 "Face that should be used for highlighting FIELD containing VALUE."
1526 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1533 rear-nonsticky t))
1536 field))
1539 "Update face of FIELD."
1546 "Non-nil if CUSTOM can validly have the value VALUE."
1550 "Face used for a FIELD."
1554 "Read from CUSTOM an STRING."
1571 "Write CUSTOM SEXP as string."
1574 string
1580 "Read string by ignoring trailing padding characters."
1589 "Write raw string."
1590 string)
1593 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1597 nil)
1600 ;; Convert CUSTOM's VALUE to external representation.
1601 ;; See `custom-import'.
1604 value))
1607 "Quote CUSTOM's VALUE if necessary."
1610 value
1613 value
1616 value)))
1619 "Initialize `doc' and `default' entries in CUSTOM."
1622 ()
1636 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1640 ()
1645 field))
1648 "Store a new value into field FIELD, taking it from VALUE."
1655 "Apply any changes in FIELD since the last apply."
1664 "Reset content of editing FIELD to `original'."
1668 "Reset content of editing FIELD to `default'."
1675 "Prompt for a FIELD"
1687 "Match CUSTOM with VALUES."
1688 values)
1691 "Extract CUSTOM's content in FIELD."
1695 "Validate FIELD."
1703 nil)
1708 "Face used for a FIELD."
1711 custom-field-uninitialized-face)
1713 custom-field-invalid-face)
1715 custom-field-modified-face)
1717 custom-field-face))))
1720 "Update the content of FIELD."
1727 ;; Keep track of how many modified fields we have.
1733 ;; Update the field.
1746 ;;; Create Buffer:
1747 ;;
1748 ;; Public functions to create a customization buffer and to insert
1749 ;; various forms of text, fields, and buttons in it.
1752 "Customize GNU Emacs.
1753 Create a *Customize* buffer with editable customization information
1754 about GNU Emacs."
1760 "Create a customization buffer named NAME.
1761 If the optional argument CUSTOM is non-nil, use that as the custom declaration.
1762 If the optional argument TYPES is non-nil, use that as the local types.
1763 If the optional argument SET is non-nil, use that to set external data.
1764 If the optional argument GET is non-nil, use that to get external data.
1765 If the optional argument SAVE is non-nil, use that for saving changes."
1771 ()
1775 ()
1779 ()
1783 ()
1808 "Insert custom declaration CUSTOM in current buffer at level LEVEL."
1812 nil)
1820 field)))
1823 "Insert TEXT in current buffer."
1827 "Insert TAG for FIELD in current buffer."
1836 "Insert documentation from CUSTOM in current buffer."
1839 ()
1843 "Insert ARGS as documentation text."
1849 "Describe how to execute COMMAND."
1854 mouse-face custom-mouse-face
1860 ;;; Mode:
1861 ;;
1862 ;; The Customization major mode and interactive commands.
1867 nil
1869 (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button)
1873 (define-key custom-mode-map "\C-k" 'custom-kill-line)
1874 (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
1875 (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
1876 (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset)
1877 (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all)
1878 (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
1879 (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
1880 (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit)
1881 (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
1883 ;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
1884 ;; forward-field, C-b backward-field, C-n next-field, C-p
1885 ;; previous-field, ? describe-field.
1887 (defun custom-mode ()
1888 "Major mode for doing customizations.
1891 (kill-all-local-variables)
1892 (setq major-mode 'custom-mode
1893 mode-name "Custom")
1894 (use-local-map custom-mode-map)
1895 (make-local-variable 'before-change-functions)
1896 (setq before-change-functions '(custom-before-change))
1897 (make-local-variable 'after-change-functions)
1898 (setq after-change-functions '(custom-after-change))
1899 (if (not (fboundp 'make-local-hook))
1900 ;; Emacs 19.28 and earlier.
1901 (add-hook 'post-command-hook
1902 (lambda ()
1903 (if (eq major-mode 'custom-mode)
1904 (custom-post-command))))
1905 ;; Emacs 19.29.
1906 (make-local-hook 'post-command-hook)
1907 (add-hook 'post-command-hook 'custom-post-command nil t)))
1909 (defun custom-forward-field (arg)
1910 "Move point to the next field or button.
1911 With optional ARG, move across that many fields."
1912 (interactive "p")
1913 (while (> arg 0)
1914 (let ((next (if (get-text-property (point) 'custom-tag)
1915 (next-single-property-change (point) 'custom-tag)
1916 (point))))
1917 (setq next (or (next-single-property-change next 'custom-tag)
1918 (next-single-property-change (point-min) 'custom-tag)))
1919 (if next
1920 (goto-char next)
1921 (error "No customization fields in this buffer.")))
1922 (or (get-text-property (point) 'custom-jump)
1923 (setq arg (1- arg))))
1924 (while (< arg 0)
1925 (let ((previous (if (get-text-property (1- (point)) 'custom-tag)
1926 (previous-single-property-change (point) 'custom-tag)
1927 (point))))
1928 (setq previous
1929 (or (previous-single-property-change previous 'custom-tag)
1930 (previous-single-property-change (point-max) 'custom-tag)))
1931 (if previous
1932 (goto-char previous)
1933 (error "No customization fields in this buffer.")))
1934 (or (get-text-property (1- (point)) 'custom-jump)
1935 (setq arg (1+ arg)))))
1937 (defun custom-backward-field (arg)
1938 "Move point to the previous field or button.
1939 With optional ARG, move across that many fields."
1940 (interactive "p")
1941 (custom-forward-field (- arg)))
1943 (defun custom-toggle-documentation (&optional arg)
1944 "Toggle display of documentation text.
1945 If the optional argument is non-nil, show text iff the argument is positive."
1946 (interactive "P")
1947 (let ((hide (or (and (null arg)
1948 (null (custom-category-get
1949 'custom-documentation-properties 'invisible)))
1950 (<= (prefix-numeric-value arg) 0))))
1951 (custom-category-put 'custom-documentation-properties 'invisible hide)
1952 (custom-category-put 'custom-documentation-properties intangible hide))
1953 (redraw-display))
1955 (defun custom-enter-value (field data)
1956 "Enter value for current customization field or push button."
1957 (interactive (list (get-text-property (point) 'custom-tag)
1958 (get-text-property (point) 'custom-data)))
1959 (cond (data
1960 (funcall field data))
1961 ((eq field 'custom-enter-value)
1962 (error "Don't be silly"))
1963 ((and (symbolp field) (fboundp field))
1964 (call-interactively field))
1965 (field
1966 (custom-field-query field))
1967 (t
1968 (message "Nothing to enter here"))))
1970 (defun custom-kill-line ()
1971 "Kill to end of field or end of line, whichever is first."
1972 (interactive)
1973 (let ((field (get-text-property (point) 'custom-field))
1975 (next (next-single-property-change (point) 'custom-field)))
1976 (if (and field (> newline next))
1977 (kill-region (point) next)
1978 (call-interactively 'kill-line))))
1980 (defun custom-push-button (event)
1981 "Activate button below mouse pointer."
1982 (interactive "@e")
1983 (let* ((pos (event-point event))
1984 (field (get-text-property pos 'custom-field))
1985 (tag (get-text-property pos 'custom-tag))
1986 (data (get-text-property pos 'custom-data)))
1987 (cond (data
1988 (funcall tag data))
1989 ((and (symbolp tag) (fboundp tag))
1990 (call-interactively tag))
1991 (field
1992 (call-interactively (lookup-key global-map (this-command-keys))))
1993 (tag
1994 (custom-enter-value tag data))
1995 (t
1996 (error "Nothing to click on here.")))))
1998 (defun custom-reset-all ()
1999 "Undo any changes since the last apply in all fields."
2000 (interactive (and custom-modified-list
2001 (not (y-or-n-p "Discard all changes? "))
2002 (error "Reset aborted")))
2003 (let ((all custom-name-fields)
2004 current field)
2005 (while all
2006 (setq current (car all)
2007 field (cdr current)
2008 all (cdr all))
2009 (custom-field-reset field))))
2011 (defun custom-field-reset (field)
2012 "Undo any changes in FIELD since the last apply."
2013 (interactive (list (or (get-text-property (point) 'custom-field)
2014 (get-text-property (point) 'custom-tag))))
2015 (if (arrayp field)
2016 (let* ((custom (custom-field-custom field))
2017 (name (custom-name custom)))
2018 (save-excursion
2019 (if name
2020 (custom-field-original-set
2021 field (car (custom-import custom (custom-external name)))))
2022 (if (not (custom-valid custom (custom-field-original field)))
2023 (error "This field cannot be reset alone")
2024 (funcall (custom-property custom 'reset) field)
2025 (funcall (custom-property custom 'synchronize) field))))))
2027 (defun custom-factory-reset-all ()
2028 "Reset all field to their default values."
2029 (interactive (and custom-modified-list
2030 (not (y-or-n-p "Discard all changes? "))
2031 (error "Reset aborted")))
2032 (let ((all custom-name-fields)
2033 field)
2034 (while all
2035 (setq field (cdr (car all))
2036 all (cdr all))
2037 (custom-field-factory-reset field))))
2039 (defun custom-field-factory-reset (field)
2040 "Reset FIELD to its default value."
2041 (interactive (list (or (get-text-property (point) 'custom-field)
2042 (get-text-property (point) 'custom-tag))))
2043 (if (arrayp field)
2044 (save-excursion
2045 (funcall (custom-property (custom-field-custom field) 'factory-reset)
2046 field))))
2048 (defun custom-apply-all ()
2049 "Apply any changes since the last reset in all fields."
2050 (interactive (if custom-modified-list
2051 nil
2052 (error "No changes to apply.")))
2053 (custom-field-parse custom-field-last)
2054 (let ((all custom-name-fields)
2055 field)
2056 (while all
2057 (setq field (cdr (car all))
2058 all (cdr all))
2059 (let ((error (custom-field-validate (custom-field-custom field) field)))
2060 (if (null error)
2061 ()
2062 (goto-char (car error))
2063 (error (cdr error))))))
2064 (let ((all custom-name-fields)
2065 field)
2066 (while all
2067 (setq field (cdr (car all))
2068 all (cdr all))
2069 (custom-field-apply field))))
2071 (defun custom-field-apply (field)
2072 "Apply any changes in FIELD since the last apply."
2073 (interactive (list (or (get-text-property (point) 'custom-field)
2074 (get-text-property (point) 'custom-tag))))
2075 (custom-field-parse custom-field-last)
2076 (if (arrayp field)
2077 (let* ((custom (custom-field-custom field))
2078 (error (custom-field-validate custom field)))
2079 (if error
2080 (error (cdr error)))
2081 (funcall (custom-property custom 'apply) field))))
2083 (defun custom-toggle-hide (&rest ignore)
2084 "Hide or show entry."
2085 (interactive)
2086 (error "This button is not yet implemented"))
2088 (defun custom-save-and-exit ()
2089 "Save and exit customization buffer."
2090 (interactive "@")
2091 (save-excursion
2092 (funcall custom-save))
2093 (kill-buffer (current-buffer)))
2095 (defun custom-save ()
2096 "Save customization information."
2097 (interactive)
2098 (custom-apply-all)
2099 (let ((new custom-name-fields))
2100 (set-buffer (find-file-noselect custom-file))
2101 (goto-char (point-min))
2102 (save-excursion
2103 (let ((old (condition-case nil
2104 (read (current-buffer))
2105 (end-of-file (append '(setq custom-dummy
2106 'custom-dummy) ())))))
2107 (or (eq (car old) 'setq)
2108 (error "Invalid customization file: %s" custom-file))
2109 (while new
2110 (let* ((field (cdr (car new)))
2111 (custom (custom-field-custom field))
2112 (value (custom-field-original field))
2113 (default (car (custom-import custom (custom-default custom))))
2114 (name (car (car new))))
2115 (setq new (cdr new))
2116 (custom-assert '(eq name (custom-name custom)))
2117 (if (equal default value)
2118 (setcdr old (custom-plist-delq name (cdr old)))
2119 (setcdr old (plist-put (cdr old) name
2120 (car (custom-quote custom value)))))))
2121 (erase-buffer)
2122 (insert ";; " custom-file "\
2123 --- Automatically generated customization information.
2124 ;;
2125 ;; Feel free to edit by hand, but the entire content should consist of
2126 ;; a single setq. Any other lisp expressions will confuse the
2127 ;; automatic configuration engine.
2129 \(setq ")
2130 (setq old (cdr old))
2131 (while old
2132 (prin1 (car old) (current-buffer))
2133 (setq old (cdr old))
2134 (insert " ")
2135 (pp (car old) (current-buffer))
2136 (setq old (cdr old))
2139 (save-buffer)
2140 (kill-buffer (current-buffer))))))
2142 (defun custom-load ()
2143 "Save customization information."
2144 (interactive (and custom-modified-list
2145 (not (equal (list (custom-name-field 'custom-file))
2146 custom-modified-list))
2147 (not (y-or-n-p "Discard all changes? "))
2148 (error "Load aborted")))
2149 (load-file (custom-name-value 'custom-file))
2150 (custom-reset-all))
2152 ;;; Field Editing:
2153 ;;
2154 ;; Various internal functions for implementing the direct editing of
2155 ;; fields in the customization buffer.
2157 (defun custom-field-untouch (field)
2158 ;; Remove FIELD and its children from `custom-modified-list'.
2159 (setq custom-modified-list (delq field custom-modified-list))
2160 (if (arrayp field)
2161 (let ((value (custom-field-value field)))
2162 (cond ((null (custom-data (custom-field-custom field))))
2163 ((arrayp value)
2164 (custom-field-untouch value))
2165 ((listp value)
2166 (mapcar 'custom-field-untouch value))))))
2169 (defun custom-field-insert (field)
2170 ;; Insert editing FIELD in current buffer.
2171 (let ((from (point))
2172 (custom (custom-field-custom field))
2173 (value (custom-field-value field)))
2174 (insert (custom-write custom value))
2175 (insert-char (custom-padding custom)
2176 (- (custom-width custom) (- (point) from)))
2177 (custom-field-move field from (point))
2178 (set-text-properties
2179 from (point)
2180 (list 'custom-field field
2181 'custom-tag field
2182 'face (custom-field-face field)
2183 front-sticky t))))
2185 (defun custom-field-read (field)
2186 ;; Read the screen content of FIELD.
2187 (custom-read (custom-field-custom field)
2188 (buffer-substring-no-properties (custom-field-start field)
2189 (custom-field-end field))))
2191 ;; Fields are shown in a special `active' face when point is inside
2192 ;; it. You activate the field by moving point inside (entering) it
2193 ;; and deactivate the field by moving point outside (leaving) it.
2195 (defun custom-field-leave (field)
2196 ;; Deactivate FIELD.
2197 (let ((before-change-functions nil)
2198 (after-change-functions nil))
2199 (put-text-property (custom-field-start field) (custom-field-end field)
2200 'face (custom-field-face field))))
2202 (defun custom-field-enter (field)
2203 ;; Activate FIELD.
2204 (let* ((start (custom-field-start field))
2205 (end (custom-field-end field))
2206 (custom (custom-field-custom field))
2207 (padding (custom-padding custom))
2208 (before-change-functions nil)
2209 (after-change-functions nil))
2210 (or (eq this-command 'self-insert-command)
2211 (let ((pos end))
2212 (while (and (< start pos)
2213 (eq (char-after (1- pos)) padding))
2214 (setq pos (1- pos)))
2215 (if (< pos (point))
2216 (goto-char pos))))
2217 (put-text-property start end 'face custom-field-active-face)))
2219 (defun custom-field-resize (field)
2220 ;; Resize FIELD after change.
2221 (let* ((custom (custom-field-custom field))
2222 (begin (custom-field-start field))
2223 (end (custom-field-end field))
2224 (pos (point))
2225 (padding (custom-padding custom))
2226 (width (custom-width custom))
2227 (size (- end begin)))
2228 (cond ((< size width)
2229 (goto-char end)
2230 (if (fboundp 'insert-before-markers-and-inherit)
2231 ;; Emacs 19.
2232 (insert-before-markers-and-inherit
2233 (make-string (- width size) padding))
2234 ;; XEmacs: BUG: Doesn't work!
2235 (insert-before-markers (make-string (- width size) padding)))
2236 (goto-char pos))
2237 ((> size width)
2238 (let ((start (if (and (< (+ begin width) pos) (<= pos end))
2239 pos
2240 (+ begin width))))
2241 (goto-char end)
2242 (while (and (< start (point)) (= (preceding-char) padding))
2243 (backward-delete-char 1))
2244 (goto-char pos))))))
2246 (defvar custom-field-changed nil)
2247 ;; List of fields changed on the screen but whose VALUE attribute has
2248 ;; not yet been updated to reflect the new screen content.
2249 (make-variable-buffer-local 'custom-field-changed)
2251 (defun custom-field-parse (field)
2252 ;; Parse FIELD content iff changed.
2253 (if (memq field custom-field-changed)
2254 (progn
2255 (setq custom-field-changed (delq field custom-field-changed))
2256 (custom-field-value-set field (custom-field-read field))
2257 (custom-field-update field))))
2259 (defun custom-post-command ()
2260 ;; Keep track of their active field.
2261 (custom-assert '(eq major-mode 'custom-mode))
2262 (let ((field (custom-field-property (point))))
2263 (if (eq field custom-field-last)
2264 (if (memq field custom-field-changed)
2265 (custom-field-resize field))
2266 (custom-field-parse custom-field-last)
2267 (if custom-field-last
2268 (custom-field-leave custom-field-last))
2269 (if field
2270 (custom-field-enter field))
2271 (setq custom-field-last field))
2272 (set-buffer-modified-p (or custom-modified-list
2273 custom-field-changed))))
2275 (defvar custom-field-was nil)
2276 ;; The custom data before the change.
2277 (make-variable-buffer-local 'custom-field-was)
2279 (defun custom-before-change (begin end)
2280 ;; Check that we the modification is allowed.
2281 (if (not (eq major-mode 'custom-mode))
2282 (message "Aargh! Why is custom-before-change called here?")
2283 (let ((from (custom-field-property begin))
2284 (to (custom-field-property end)))
2285 (cond ((or (null from) (null to))
2286 (error "You can only modify the fields"))
2287 ((not (eq from to))
2288 (error "Changes must be limited to a single field."))
2289 (t
2290 (setq custom-field-was from))))))
2292 (defun custom-after-change (begin end length)
2293 ;; Keep track of field content.
2294 (if (not (eq major-mode 'custom-mode))
2295 (message "Aargh! Why is custom-after-change called here?")
2296 (let ((field custom-field-was))
2297 (custom-assert '(prog1 field (setq custom-field-was nil)))
2298 ;; Prevent mixing fields properties.
2299 (put-text-property begin end 'custom-field field)
2300 ;; Update the field after modification.
2301 (if (eq (custom-field-property begin) field)
2302 (let ((field-end (custom-field-end field)))
2303 (if (> end field-end)
2304 (set-marker field-end end))
2305 (add-to-list 'custom-field-changed field))
2306 ;; We deleted the entire field, reinsert it.
2307 (custom-assert '(eq begin end))
2308 (save-excursion
2309 (goto-char begin)
2310 (custom-field-value-set field
2311 (custom-read (custom-field-custom field) ""))
2312 (custom-field-insert field))))))
2314 (defun custom-field-property (pos)
2315 ;; The `custom-field' text property valid for POS.
2316 (or (get-text-property pos 'custom-field)
2317 (and (not (eq pos (point-min)))
2318 (get-text-property (1- pos) 'custom-field))))
2320 ;;; Generic Utilities:
2321 ;;
2322 ;; Some utility functions that are not really specific to custom.
2324 (defun custom-assert (expr)
2325 "Assert that EXPR evaluates to non-nil at this point"
2326 (or (eval expr)
2327 (error "Assertion failed: %S" expr)))
2329 (defun custom-first-line (string)
2330 "Return the part of STRING before the first newline."
2331 (let ((pos 0)
2332 (len (length string)))
2334 (setq pos (1+ pos)))
2335 (if (eq pos len)
2336 string
2337 (substring string 0 pos))))
2339 (defun custom-insert-before (list old new)
2340 "In LIST insert before OLD a NEW element."
2341 (cond ((null list)
2342 (list new))
2343 ((null old)
2344 (nconc list (list new)))
2345 ((eq old (car list))
2346 (cons new list))
2347 (t
2348 (let ((list list))
2349 (while (not (eq old (car (cdr list))))
2350 (setq list (cdr list))
2351 (custom-assert '(cdr list)))
2352 (setcdr list (cons new (cdr list))))
2353 list)))
2355 (defun custom-strip-padding (string padding)
2356 "Remove padding from STRING."
2357 (let ((regexp (concat (regexp-quote (char-to-string padding)) "+")))
2358 (while (string-match regexp string)
2359 (setq string (concat (substring string 0 (match-beginning 0))
2360 (substring string (match-end 0))))))
2361 string)
2363 (defun custom-plist-memq (prop plist)
2364 "Return non-nil if PROP is a property of PLIST. Comparison done with EQ."
2365 (let (result)
2366 (while plist
2367 (if (eq (car plist) prop)
2368 (setq result plist
2369 plist nil)
2370 (setq plist (cdr (cdr plist)))))
2371 result))
2373 (defun custom-plist-delq (prop plist)
2374 "Delete property PROP from property list PLIST."
2375 (while (eq (car plist) prop)
2376 (setq plist (cdr (cdr plist))))
2377 (let ((list plist)
2378 (next (cdr (cdr plist))))
2379 (while next
2380 (if (eq (car next) prop)
2381 (progn
2382 (setq next (cdr (cdr next)))
2383 (setcdr (cdr list) next))
2384 (setq list next
2385 next (cdr (cdr next))))))
2386 plist)
2388 ;;; Meta Customization:
2390 (custom-declare '()
2391 '((tag . "Meta Customization")
2392 (doc . "Customization of the customization support.")
2393 (type . group)
2394 (data ((type . face-doc))
2395 ((tag . "Button Face")
2396 (default . bold)
2397 (doc . "Face used for tags in customization buffers.")
2398 (name . custom-button-face)
2399 (synchronize . (lambda (f)
2400 (custom-category-put 'custom-button-properties
2401 'face custom-button-face)))
2402 (type . face))
2403 ((tag . "Mouse Face")
2404 (default . highlight)
2405 (doc . "\
2406 Face used when mouse is above a button in customization buffers.")
2407 (name . custom-mouse-face)
2408 (synchronize . (lambda (f)
2409 (custom-category-put 'custom-button-properties
2410 mouse-face
2411 custom-mouse-face)))
2412 (type . face))
2413 ((tag . "Field Face")
2414 (default . italic)
2415 (doc . "Face used for customization fields.")
2416 (name . custom-field-face)
2417 (type . face))
2418 ((tag . "Uninitialized Face")
2419 (default . modeline)
2420 (doc . "Face used for uninitialized customization fields.")
2421 (name . custom-field-uninitialized-face)
2422 (type . face))
2423 ((tag . "Invalid Face")
2424 (default . highlight)
2425 (doc . "\
2426 Face used for customization fields containing invalid data.")
2427 (name . custom-field-invalid-face)
2428 (type . face))
2429 ((tag . "Modified Face")
2430 (default . bold-italic)
2431 (doc . "Face used for modified customization fields.")
2432 (name . custom-field-modified-face)
2433 (type . face))
2434 ((tag . "Active Face")
2435 (default . underline)
2436 (doc . "\
2437 Face used for customization fields while they are being edited.")
2438 (name . custom-field-active-face)
2439 (type . face)))))
2441 ;; custom.el uses two categories.
2443 (custom-category-create 'custom-documentation-properties)
2444 (custom-category-put 'custom-documentation-properties rear-nonsticky t)
2446 (custom-category-create 'custom-button-properties)
2447 (custom-category-put 'custom-button-properties 'face custom-button-face)
2448 (custom-category-put 'custom-button-properties mouse-face custom-mouse-face)
2449 (custom-category-put 'custom-button-properties rear-nonsticky t)
2451 (custom-category-create 'custom-hidden-properties)
2452 (custom-category-put 'custom-hidden-properties 'invisible
2453 (not (string-match "XEmacs" emacs-version)))
2454 (custom-category-put 'custom-hidden-properties intangible t)
2456 (if (file-readable-p custom-file)
2457 (load-file custom-file))
2459 (provide 'custom)
2461 ;;; custom.el ends here