| blob | 910ef02b1872a7e17c4bb9a69be3d0663ad1522a |
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:
74 ;;; Compatibility:
101 'buffer-substring-no-properties
111 "Return the text from BEG to END, without text properties, as a string."
114 string))
117 ;; Introduced in Emacs 19.29.
119 "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
120 If you want to use `add-to-list' on a variable that is not defined
121 until a certain package is loaded, you should put the call to `add-to-list'
122 into a hook function that will be run only after loading the package.
123 `eval-after-load' provides one way to do this. In some cases
124 other hooks, such as major mode hooks, can do the job."
129 ;; Introduced in Emacs 19.29.
131 "Extract a value from a property list.
132 PLIST is a property list, which is a list of the form
133 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
134 corresponding to the given PROP, or nil if PROP is not
135 one of the properties on the list."
140 plist nil)
142 result)))
145 ;; Introduced in Emacs 19.29.
147 "Change value in PLIST of PROP to VAL.
148 PLIST is a property list, which is a list of the form
149 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
150 If PROP is already a property on the list, its value is set to VAL,
151 otherwise the new PROP VAL pair is added. The new plist is returned;
152 use `(setq x (plist-put x prop val))' to be sure to use the new value.
153 The PLIST is modified by side effects."
166 plist)))
169 ;; Introduced in Emacs 19.29.
171 "Return string of text matched by last search.
172 NUM specifies which parenthesized expression in the last regexp.
173 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
174 Zero means the entire text matched by the whole regexp or whole string.
175 STRING should be given if the last search was by `string-match' on STRING."
182 ;; Introduced in Emacs 19.29.
184 "Return t if X is a face name or an internal face vector."
189 t)))
191 ;; XEmacs and Emacs 19.29 facep does different things.
197 ()
198 ;; No underline face in XEmacs 19.12.
201 ;; Must avoid calling set-face-underline-p directly, because it
202 ;; is a defsubst in emacs19, and will make the .elc files non
203 ;; portable!
219 ;; Missing in Emacs 19.29.
221 "Return the character position of the given mouse-motion, button-press,
222 or button-release event. If the event did not occur over a window, or did
223 not occur over text, then this returns nil. Otherwise, it returns an index
224 into the buffer visible in the event's window."
237 ;; We can't easily check for a working intangible.
247 'end-open
252 'front-closed
257 'highlight
261 ;; Put it in the Help menu, if possible.
264 ;; XEmacs (disabled because it doesn't work)
267 ;; Emacs 19.28 and earlier
270 ;; Emacs 19.29 and later
274 ;; XEmacs popup-menu stolen from w3.el.
276 "My hacked up function to do a blocking popup menu..."
278 event menu)
293 nil)
297 nil)
302 ;;; Categories:
303 ;;
304 ;; XEmacs use inheritable extents for the same purpose as Emacs uses
305 ;; the category text property.
309 ;; XEmacs categories.
315 "In CATEGORY set PROPERTY to VALUE."
319 "In CATEGORY get PROPERTY."
323 "Make text between FROM and TWO have category CATEGORY."
327 ;; Emacs categories.
329 "Create a text property category named NAME."
333 "In CATEGORY set PROPERTY to VALUE."
337 "In CATEGORY get PROPERTY."
341 "Make text between FROM and TWO have category CATEGORY."
344 ;;; External Data:
345 ;;
346 ;; The following functions and variables defines the interface for
347 ;; connecting a CUSTOM with an external entity, by default an emacs
348 ;; lisp variable.
357 "Get the external value associated with NAME."
361 "Set the external value associated with NAME to VALUE."
369 "Associate NAME with FIELD."
371 ()
376 "The editing field associated with NAME."
380 "The value currently displayed for NAME in the customization buffer."
390 ;;; Custom Functions:
391 ;;
392 ;; The following functions are part of the public interface to the
393 ;; CUSTOM datastructure. Each CUSTOM describes a group of variables,
394 ;; a single variable, or a component of a structured variable. The
395 ;; CUSTOM instances are part of two hierarchies, the first is the
396 ;; `part-of' hierarchy in which each CUSTOM is a component of another
397 ;; CUSTOM, except for the top level CUSTOM which is contained in
398 ;; `custom-data'. The second hierarchy is a `is-a' type hierarchy
399 ;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
400 ;; property and `custom-type-properties'.
414 Press [Save] to save any changes permanently after you are done editing.
415 You can load customization information from other files by editing the
416 `File' field and pressing the [Load] button. When you press [Save] the
417 customization information of all files you have loaded, plus any
418 changes you might have made manually, will be stored in the file
431 "The global customization information.
435 "Declare variables for customization.
436 PATH is a list of tags leading to the place in the customization
437 hierarchy the new entry should be added. CUSTOM is the entry to add."
447 ;; See `custom-match'.
461 ;; A cons-cell.
469 ;; A lisp list.
475 ;; See `custom-match'.
490 ;; Booleans.
498 ;; On/Off/Default.
509 ;; See `custom-match'.
519 ;; A `const' only matches a single lisp value.
526 ;; A variable containing a face.
528 You can customize the look of Emacs by deciding which faces should be
529 used when. If you push one of the face buttons below, you will be
530 given a choice between a number of standard faces. The name of the
531 selected face is shown right after the face button, and it is
532 displayed its own face so you can see how it looks. If you know of
533 another standard face not listed and want to use it, you can select
534 `Other' and write the name in the editing field.
536 If none of the standard faces suits you, you can select `Customize' to
537 create your own face. This will make six fields appear under the face
538 button. The `Fg' and `Bg' fields are the foreground and background
539 colors for the face, respectively. You should type the name of the
540 color in the field. You can use any X11 color name. A list of X11
541 color names may be available in the file `/usr/lib/X11/rgb.txt' on
542 your system. The special color name `default' means that the face
543 will not change the color of the text. The `Stipple' field is weird,
544 so just ignore it. The three remaining fields are toggles, which will
545 make the text `bold', `italic', or `underline' respectively. For some
617 " "
621 " "
627 nil nil nil))
634 ;; A string containing a file or directory name.
639 ;; Any lisp expression.
645 ;; A lisp symbol.
649 ;; A lisp integer.
653 ;; A lisp string.
659 ;; Push me.
665 ;; A documentation only entry with no value.
701 "Alist of default properties for type symbols.
705 "Local type properties.
717 ;; Bad, ugly, and horrible kludge.
720 "Extract from CUSTOM property PROPERTY."
723 ;; Look in superclass.
732 "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass."
735 ;; Look in superclass.
744 "Set CUSTOM PROPERTY to VALUE by side effect.
745 CUSTOM must have at least one property already."
752 "Extract `type' from CUSTOM."
756 "Extract `name' from CUSTOM."
760 "Extract `tag' from CUSTOM."
764 "Extract `face-tag' from CUSTOM."
768 "Extract `prompt' from CUSTOM.
769 If none exist, default to `tag' or, failing that, `type'."
775 "Extract `default' from CUSTOM."
782 "Extract the `data' from CUSTOM."
786 "Extract `doc' from CUSTOM."
790 "Extract `width' from CUSTOM."
794 "Extract `compact' from CUSTOM."
798 "Extract `padding' from CUSTOM."
802 "Non-nil if CUSTOM may validly be set to VALUE."
807 "Import CUSTOM VALUE from external variable.
809 This function change VALUE into a form that makes it easier to edit
810 internally. What the internal form is exactly depends on CUSTOM.
811 The internal form is returned."
817 "Return non-nil if CUSTOM's VALUE needs to be evaluated."
821 "Quote CUSTOM's VALUE if necessary."
825 "Convert CUSTOM VALUE to a string."
834 "Convert CUSTOM field content STRING into lisp."
840 "Match CUSTOM with a list of VALUES.
842 Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
843 and the cdr is the remaining VALUES.
845 A CUSTOM is actually a regular expression over the alphabet of lisp
846 types. Most CUSTOM types are just doing a literal match, e.g. the
847 `symbol' type matches any lisp symbol. The exceptions are:
849 group: which corresponds to a `(' and `)' group in a regular expression.
850 choice: which corresponds to a group of `|' in a regular expression.
851 repeat: which corresponds to a `*' in a regular expression.
852 optional: which corresponds to a `?', and isn't implemented yet."
854 ;; Nothing matches the uninitialized or empty list.
859 "Initialize `doc' and `default' attributes of CUSTOM."
863 "Find child in CUSTOM with `tag' TAG."
867 "Find decedent of CUSTOM by looking through PATH."
869 custom
873 "Extract CUSTOM's value in FIELD."
875 nil
877 custom field)))
880 "Validate CUSTOM's value in FIELD.
881 Return nil if valid, otherwise return a cons-cell where the car is the
882 position of the error, and the cdr is a text describing the error."
884 nil
887 ;;; Field Functions:
888 ;;
889 ;; This section defines the public functions for manipulating the
890 ;; FIELD datatype. The FIELD instance hold information about a
891 ;; specific editing field in the customization buffer.
892 ;;
893 ;; Each FIELD can be seen as an instantiation of a CUSTOM.
896 ;; Last field containing point.
900 ;; List of modified fields.
904 "Create a field structure of type CUSTOM containing VALUE.
906 A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
907 CUSTOM defines the type of the field,
908 VALUE is the current value of the field,
909 ORIGINAL is the original value when created, and
910 START and END are markers to the start and end of the field."
914 "Return the `custom' attribute of FIELD."
918 "Return the `value' attribute of FIELD."
922 "Return the `original' attribute of FIELD."
926 "Return the `start' attribute of FIELD."
930 "Return the `end' attribute of FIELD."
934 "Set the `value' attribute of FIELD to VALUE."
938 "Set the `original' attribute of FIELD to ORIGINAL."
942 "Set the `start'and `end' attributes of FIELD to START and END."
947 "Query user for content of current field."
951 "Store a new value into field FIELD, taking it from VALUE.
952 If optional ORIGINAL is non-nil, consider VALUE for the original value."
955 field value original)))
958 "The face used for highlighting FIELD."
961 nil
966 "Update the screen appearance of FIELD to correspond with the field's value."
969 nil
972 ;;; Types:
973 ;;
974 ;; The following functions defines type specific actions.
977 "Non-nil if CUSTOM's VALUE needs to be evaluated."
979 nil
983 value))))
986 "A list of CUSTOM's VALUEs quoted."
989 value))))
993 "Modify CUSTOM's VALUE to match internal expectations."
996 value))))
999 "Store a new value into field FIELD, taking it from VALUE."
1003 current new)
1010 ;; Change existing field.
1013 ;; Insert new field if series has grown.
1020 ;; Delete old field if series has scrunk.
1024 data)
1036 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1048 field))
1051 "Insert entry at point in the REPEAT field."
1062 field)
1077 field))
1080 "Add list entry."
1084 new)
1089 field new))))
1092 "Delete list entry."
1105 "Match CUSTOM with VALUES."
1108 matches)
1116 "Extract list of children's values."
1119 result)
1121 ()
1125 result))
1128 "Validate children."
1131 result)
1137 result))
1140 "Store a new value into field FIELD, taking it from VALUE."
1144 "Non-nil if CUSTOM's VALUE needs to be evaluated."
1148 "Modify CUSTOM's VALUE to match internal expectations."
1155 "Quote CUSTOM's VALUE if necessary."
1163 "Extract cons of children's values."
1166 result)
1177 "Quote CUSTOM's VALUE if necessary."
1184 "Extract list of children's values."
1187 result)
1198 "Validate children."
1201 result)
1209 result))
1212 "Non-nil if CUSTOM's VALUE needs to be evaluated."
1221 found))
1224 "A list of CUSTOM's VALUE members, quoted."
1228 ()
1235 "Modify CUSTOM's VALUE to match internal expectations."
1239 ()
1246 "Initialize `doc' and `default' entries in CUSTOM."
1252 "Reset `value' in FIELD to `original'."
1260 "Reset `value' in FIELD to `original'."
1268 "Reset `value' in FIELD to `default'."
1276 "Find child in CUSTOM with `tag' TAG."
1286 "Store a new value into field FIELD, taking it from VALUE."
1291 current)
1307 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1309 fields hidden
1321 fields))
1331 field))
1334 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1341 field))
1344 "Store a new value into field FIELD, taking it from VALUE."
1351 from)
1369 found begin)
1376 ()
1390 "Extract child's value."
1395 "Validate child's value."
1404 "Choose a child."
1410 current alist)
1423 last-input-event tag
1425 alist)))
1431 " (default "
1432 default
1434 alist nil t)))
1442 "Prompt for a file name"
1457 ""
1458 directory)
1459 default nil value)
1463 "Return non-nil if CUSTOM's VALUE needs to be evaluated."
1467 "Modify CUSTOM's VALUE to match internal expectations."
1472 name)
1480 value))))
1483 "Lookup or create a face with specified attributes."
1488 bold italic underline))))
1491 ()
1523 name))
1526 "Face that should be used for highlighting FIELD containing VALUE."
1533 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1540 rear-nonsticky t))
1543 field))
1546 "Update face of FIELD."
1553 "Non-nil if CUSTOM can validly have the value VALUE."
1557 "Face used for a FIELD."
1561 "Read from CUSTOM an STRING."
1578 "Write CUSTOM SEXP as string."
1581 string
1587 "Read string by ignoring trailing padding characters."
1596 "Write raw string."
1597 string)
1600 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1604 nil)
1607 ;; Convert CUSTOM's VALUE to external representation.
1608 ;; See `custom-import'.
1611 value))
1614 "Quote CUSTOM's VALUE if necessary."
1617 value
1620 value
1623 value)))
1626 "Initialize `doc' and `default' entries in CUSTOM."
1629 ()
1643 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1647 ()
1652 field))
1655 "Store a new value into field FIELD, taking it from VALUE."
1662 "Apply any changes in FIELD since the last apply."
1671 "Reset content of editing FIELD to `original'."
1675 "Reset content of editing FIELD to `default'."
1682 "Prompt for a FIELD"
1694 "Match CUSTOM with VALUES."
1695 values)
1698 "Extract CUSTOM's content in FIELD."
1702 "Validate FIELD."
1710 nil)
1715 "Face used for a FIELD."
1718 custom-field-uninitialized-face)
1720 custom-field-invalid-face)
1722 custom-field-modified-face)
1724 custom-field-face))))
1727 "Update the content of FIELD."
1734 ;; Keep track of how many modified fields we have.
1740 ;; Update the field.
1753 ;;; Create Buffer:
1754 ;;
1755 ;; Public functions to create a customization buffer and to insert
1756 ;; various forms of text, fields, and buttons in it.
1759 "Customize GNU Emacs.
1760 Create a *Customize* buffer with editable customization information
1761 about GNU Emacs."
1767 "Create a customization buffer named NAME.
1768 If the optional argument CUSTOM is non-nil, use that as the custom declaration.
1769 If the optional argument TYPES is non-nil, use that as the local types.
1770 If the optional argument SET is non-nil, use that to set external data.
1771 If the optional argument GET is non-nil, use that to get external data.
1772 If the optional argument SAVE is non-nil, use that for saving changes."
1778 ()
1782 ()
1786 ()
1790 ()
1815 "Insert custom declaration CUSTOM in current buffer at level LEVEL."
1819 nil)
1827 field)))
1830 "Insert TEXT in current buffer."
1834 "Insert TAG for FIELD in current buffer."
1843 "Insert documentation from CUSTOM in current buffer."
1846 ()
1850 "Insert ARGS as documentation text."
1856 "Describe how to execute COMMAND."
1861 mouse-face custom-mouse-face
1863 'custom-tag command
1864 'start-open t
1869 ;;; Mode:
1870 ;;
1871 ;; The Customization major mode and interactive commands.
1876 nil
1878 (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button)
1882 (define-key custom-mode-map "\C-k" 'custom-kill-line)
1883 (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
1884 (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
1885 (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset)
1886 (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all)
1887 (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
1888 (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
1889 (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit)
1890 (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
1892 ;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
1893 ;; forward-field, C-b backward-field, C-n next-field, C-p
1894 ;; previous-field, ? describe-field.
1896 (defun custom-mode ()
1897 "Major mode for doing customizations.
1900 (kill-all-local-variables)
1901 (setq major-mode 'custom-mode
1902 mode-name "Custom")
1903 (use-local-map custom-mode-map)
1904 (make-local-variable 'before-change-functions)
1905 (setq before-change-functions '(custom-before-change))
1906 (make-local-variable 'after-change-functions)
1907 (setq after-change-functions '(custom-after-change))
1908 (if (not (fboundp 'make-local-hook))
1909 ;; Emacs 19.28 and earlier.
1910 (add-hook 'post-command-hook
1911 (lambda ()
1912 (if (eq major-mode 'custom-mode)
1913 (custom-post-command))))
1914 ;; Emacs 19.29.
1915 (make-local-hook 'post-command-hook)
1916 (add-hook 'post-command-hook 'custom-post-command nil t)))
1918 (defun custom-forward-field (arg)
1919 "Move point to the next field or button.
1920 With optional ARG, move across that many fields."
1921 (interactive "p")
1922 (while (> arg 0)
1923 (let ((next (if (get-text-property (point) 'custom-tag)
1924 (next-single-property-change (point) 'custom-tag)
1925 (point))))
1926 (setq next (or (next-single-property-change next 'custom-tag)
1927 (next-single-property-change (point-min) 'custom-tag)))
1928 (if next
1929 (goto-char next)
1930 (error "No customization fields in this buffer.")))
1931 (or (get-text-property (point) 'custom-jump)
1932 (setq arg (1- arg))))
1933 (while (< arg 0)
1934 (let ((previous (if (get-text-property (1- (point)) 'custom-tag)
1935 (previous-single-property-change (point) 'custom-tag)
1936 (point))))
1937 (setq previous
1938 (or (previous-single-property-change previous 'custom-tag)
1939 (previous-single-property-change (point-max) 'custom-tag)))
1940 (if previous
1941 (goto-char previous)
1942 (error "No customization fields in this buffer.")))
1943 (or (get-text-property (1- (point)) 'custom-jump)
1944 (setq arg (1+ arg)))))
1946 (defun custom-backward-field (arg)
1947 "Move point to the previous field or button.
1948 With optional ARG, move across that many fields."
1949 (interactive "p")
1950 (custom-forward-field (- arg)))
1952 (defun custom-toggle-documentation (&optional arg)
1953 "Toggle display of documentation text.
1954 If the optional argument is non-nil, show text iff the argument is positive."
1955 (interactive "P")
1956 (let ((hide (or (and (null arg)
1957 (null (custom-category-get
1958 'custom-documentation-properties 'invisible)))
1959 (<= (prefix-numeric-value arg) 0))))
1960 (custom-category-put 'custom-documentation-properties 'invisible hide)
1961 (custom-category-put 'custom-documentation-properties intangible hide))
1962 (redraw-display))
1964 (defun custom-enter-value (field data)
1965 "Enter value for current customization field or push button."
1966 (interactive (list (get-text-property (point) 'custom-tag)
1967 (get-text-property (point) 'custom-data)))
1968 (cond (data
1969 (funcall field data))
1970 ((eq field 'custom-enter-value)
1971 (error "Don't be silly"))
1972 ((and (symbolp field) (fboundp field))
1973 (call-interactively field))
1974 (field
1975 (custom-field-query field))
1976 (t
1977 (message "Nothing to enter here"))))
1979 (defun custom-kill-line ()
1980 "Kill to end of field or end of line, whichever is first."
1981 (interactive)
1982 (let ((field (get-text-property (point) 'custom-field))
1984 (next (next-single-property-change (point) 'custom-field)))
1985 (if (and field (> newline next))
1986 (kill-region (point) next)
1987 (call-interactively 'kill-line))))
1989 (defun custom-push-button (event)
1990 "Activate button below mouse pointer."
1991 (interactive "@e")
1992 (let* ((pos (event-point event))
1993 (field (get-text-property pos 'custom-field))
1994 (tag (get-text-property pos 'custom-tag))
1995 (data (get-text-property pos 'custom-data)))
1996 (cond (data
1997 (funcall tag data))
1998 ((and (symbolp tag) (fboundp tag))
1999 (call-interactively tag))
2000 (field
2001 (call-interactively (lookup-key global-map (this-command-keys))))
2002 (tag
2003 (custom-enter-value tag data))
2004 (t
2005 (error "Nothing to click on here.")))))
2007 (defun custom-reset-all ()
2008 "Undo any changes since the last apply in all fields."
2009 (interactive (and custom-modified-list
2010 (not (y-or-n-p "Discard all changes? "))
2011 (error "Reset aborted")))
2012 (let ((all custom-name-fields)
2013 current field)
2014 (while all
2015 (setq current (car all)
2016 field (cdr current)
2017 all (cdr all))
2018 (custom-field-reset field))))
2020 (defun custom-field-reset (field)
2021 "Undo any changes in FIELD since the last apply."
2022 (interactive (list (or (get-text-property (point) 'custom-field)
2023 (get-text-property (point) 'custom-tag))))
2024 (if (arrayp field)
2025 (let* ((custom (custom-field-custom field))
2026 (name (custom-name custom)))
2027 (save-excursion
2028 (if name
2029 (custom-field-original-set
2030 field (car (custom-import custom (custom-external name)))))
2031 (if (not (custom-valid custom (custom-field-original field)))
2032 (error "This field cannot be reset alone")
2033 (funcall (custom-property custom 'reset) field)
2034 (funcall (custom-property custom 'synchronize) field))))))
2036 (defun custom-factory-reset-all ()
2037 "Reset all field to their default values."
2038 (interactive (and custom-modified-list
2039 (not (y-or-n-p "Discard all changes? "))
2040 (error "Reset aborted")))
2041 (let ((all custom-name-fields)
2042 field)
2043 (while all
2044 (setq field (cdr (car all))
2045 all (cdr all))
2046 (custom-field-factory-reset field))))
2048 (defun custom-field-factory-reset (field)
2049 "Reset FIELD to its default value."
2050 (interactive (list (or (get-text-property (point) 'custom-field)
2051 (get-text-property (point) 'custom-tag))))
2052 (if (arrayp field)
2053 (save-excursion
2054 (funcall (custom-property (custom-field-custom field) 'factory-reset)
2055 field))))
2057 (defun custom-apply-all ()
2058 "Apply any changes since the last reset in all fields."
2059 (interactive (if custom-modified-list
2060 nil
2061 (error "No changes to apply.")))
2062 (custom-field-parse custom-field-last)
2063 (let ((all custom-name-fields)
2064 field)
2065 (while all
2066 (setq field (cdr (car all))
2067 all (cdr all))
2068 (let ((error (custom-field-validate (custom-field-custom field) field)))
2069 (if (null error)
2070 ()
2071 (goto-char (car error))
2072 (error (cdr error))))))
2073 (let ((all custom-name-fields)
2074 field)
2075 (while all
2076 (setq field (cdr (car all))
2077 all (cdr all))
2078 (custom-field-apply field))))
2080 (defun custom-field-apply (field)
2081 "Apply any changes in FIELD since the last apply."
2082 (interactive (list (or (get-text-property (point) 'custom-field)
2083 (get-text-property (point) 'custom-tag))))
2084 (custom-field-parse custom-field-last)
2085 (if (arrayp field)
2086 (let* ((custom (custom-field-custom field))
2087 (error (custom-field-validate custom field)))
2088 (if error
2089 (error (cdr error)))
2090 (funcall (custom-property custom 'apply) field))))
2092 (defun custom-toggle-hide (&rest ignore)
2093 "Hide or show entry."
2094 (interactive)
2095 (error "This button is not yet implemented"))
2097 (defun custom-save-and-exit ()
2098 "Save and exit customization buffer."
2099 (interactive "@")
2100 (save-excursion
2101 (funcall custom-save))
2102 (kill-buffer (current-buffer)))
2104 (defun custom-save ()
2105 "Save customization information."
2106 (interactive)
2107 (custom-apply-all)
2108 (let ((new custom-name-fields))
2109 (set-buffer (find-file-noselect custom-file))
2110 (goto-char (point-min))
2111 (save-excursion
2112 (let ((old (condition-case nil
2113 (read (current-buffer))
2114 (end-of-file (append '(setq custom-dummy
2115 'custom-dummy) ())))))
2116 (or (eq (car old) 'setq)
2117 (error "Invalid customization file: %s" custom-file))
2118 (while new
2119 (let* ((field (cdr (car new)))
2120 (custom (custom-field-custom field))
2121 (value (custom-field-original field))
2122 (default (car (custom-import custom (custom-default custom))))
2123 (name (car (car new))))
2124 (setq new (cdr new))
2125 (custom-assert '(eq name (custom-name custom)))
2126 (if (equal default value)
2127 (setcdr old (custom-plist-delq name (cdr old)))
2128 (setcdr old (plist-put (cdr old) name
2129 (car (custom-quote custom value)))))))
2130 (erase-buffer)
2131 (insert ";; " custom-file "\
2132 --- Automatically generated customization information.
2133 ;;
2134 ;; Feel free to edit by hand, but the entire content should consist of
2135 ;; a single setq. Any other lisp expressions will confuse the
2136 ;; automatic configuration engine.
2138 \(setq ")
2139 (setq old (cdr old))
2140 (while old
2141 (prin1 (car old) (current-buffer))
2142 (setq old (cdr old))
2143 (insert " ")
2144 (pp (car old) (current-buffer))
2145 (setq old (cdr old))
2148 (save-buffer)
2149 (kill-buffer (current-buffer))))))
2151 (defun custom-load ()
2152 "Save customization information."
2153 (interactive (and custom-modified-list
2154 (not (equal (list (custom-name-field 'custom-file))
2155 custom-modified-list))
2156 (not (y-or-n-p "Discard all changes? "))
2157 (error "Load aborted")))
2158 (load-file (custom-name-value 'custom-file))
2159 (custom-reset-all))
2161 ;;; Field Editing:
2162 ;;
2163 ;; Various internal functions for implementing the direct editing of
2164 ;; fields in the customization buffer.
2166 (defun custom-field-untouch (field)
2167 ;; Remove FIELD and its children from `custom-modified-list'.
2168 (setq custom-modified-list (delq field custom-modified-list))
2169 (if (arrayp field)
2170 (let ((value (custom-field-value field)))
2171 (cond ((null (custom-data (custom-field-custom field))))
2172 ((arrayp value)
2173 (custom-field-untouch value))
2174 ((listp value)
2175 (mapcar 'custom-field-untouch value))))))
2178 (defun custom-field-insert (field)
2179 ;; Insert editing FIELD in current buffer.
2180 (let ((from (point))
2181 (custom (custom-field-custom field))
2182 (value (custom-field-value field)))
2183 (insert (custom-write custom value))
2184 (insert-char (custom-padding custom)
2185 (- (custom-width custom) (- (point) from)))
2186 (custom-field-move field from (point))
2187 (custom-set-text-properties
2188 from (point)
2189 (list 'custom-field field
2190 'custom-tag field
2191 'face (custom-field-face field)
2192 'start-open t
2193 'end-open t))))
2195 (defun custom-field-read (field)
2196 ;; Read the screen content of FIELD.
2197 (custom-read (custom-field-custom field)
2198 (custom-buffer-substring-no-properties (custom-field-start field)
2199 (custom-field-end field))))
2201 ;; Fields are shown in a special `active' face when point is inside
2202 ;; it. You activate the field by moving point inside (entering) it
2203 ;; and deactivate the field by moving point outside (leaving) it.
2205 (defun custom-field-leave (field)
2206 ;; Deactivate FIELD.
2207 (let ((before-change-functions nil)
2208 (after-change-functions nil))
2209 (custom-put-text-property (custom-field-start field) (custom-field-end field)
2210 'face (custom-field-face field))))
2212 (defun custom-field-enter (field)
2213 ;; Activate FIELD.
2214 (let* ((start (custom-field-start field))
2215 (end (custom-field-end field))
2216 (custom (custom-field-custom field))
2217 (padding (custom-padding custom))
2218 (before-change-functions nil)
2219 (after-change-functions nil))
2220 (or (eq this-command 'self-insert-command)
2221 (let ((pos end))
2222 (while (and (< start pos)
2223 (eq (char-after (1- pos)) padding))
2224 (setq pos (1- pos)))
2225 (if (< pos (point))
2226 (goto-char pos))))
2227 (custom-put-text-property start end 'face custom-field-active-face)))
2229 (defun custom-field-resize (field)
2230 ;; Resize FIELD after change.
2231 (let* ((custom (custom-field-custom field))
2232 (begin (custom-field-start field))
2233 (end (custom-field-end field))
2234 (pos (point))
2235 (padding (custom-padding custom))
2236 (width (custom-width custom))
2237 (size (- end begin)))
2238 (cond ((< size width)
2239 (goto-char end)
2240 (if (fboundp 'insert-before-markers-and-inherit)
2241 ;; Emacs 19.
2242 (insert-before-markers-and-inherit
2243 (make-string (- width size) padding))
2244 ;; XEmacs: BUG: Doesn't work!
2245 (insert-before-markers (make-string (- width size) padding)))
2246 (goto-char pos))
2247 ((> size width)
2248 (let ((start (if (and (< (+ begin width) pos) (<= pos end))
2249 pos
2250 (+ begin width))))
2251 (goto-char end)
2252 (while (and (< start (point)) (= (preceding-char) padding))
2253 (backward-delete-char 1))
2254 (goto-char pos))))))
2256 (defvar custom-field-changed nil)
2257 ;; List of fields changed on the screen but whose VALUE attribute has
2258 ;; not yet been updated to reflect the new screen content.
2259 (make-variable-buffer-local 'custom-field-changed)
2261 (defun custom-field-parse (field)
2262 ;; Parse FIELD content iff changed.
2263 (if (memq field custom-field-changed)
2264 (progn
2265 (setq custom-field-changed (delq field custom-field-changed))
2266 (custom-field-value-set field (custom-field-read field))
2267 (custom-field-update field))))
2269 (defun custom-post-command ()
2270 ;; Keep track of their active field.
2271 (custom-assert '(eq major-mode 'custom-mode))
2272 (let ((field (custom-field-property (point))))
2273 (if (eq field custom-field-last)
2274 (if (memq field custom-field-changed)
2275 (custom-field-resize field))
2276 (custom-field-parse custom-field-last)
2277 (if custom-field-last
2278 (custom-field-leave custom-field-last))
2279 (if field
2280 (custom-field-enter field))
2281 (setq custom-field-last field))
2282 (set-buffer-modified-p (or custom-modified-list
2283 custom-field-changed))))
2285 (defvar custom-field-was nil)
2286 ;; The custom data before the change.
2287 (make-variable-buffer-local 'custom-field-was)
2289 (defun custom-before-change (begin end)
2290 ;; Check that we the modification is allowed.
2291 (if (not (eq major-mode 'custom-mode))
2292 (message "Aargh! Why is custom-before-change called here?")
2293 (let ((from (custom-field-property begin))
2294 (to (custom-field-property end)))
2295 (cond ((or (null from) (null to))
2296 (error "You can only modify the fields"))
2297 ((not (eq from to))
2298 (error "Changes must be limited to a single field."))
2299 (t
2300 (setq custom-field-was from))))))
2302 (defun custom-after-change (begin end length)
2303 ;; Keep track of field content.
2304 (if (not (eq major-mode 'custom-mode))
2305 (message "Aargh! Why is custom-after-change called here?")
2306 (let ((field custom-field-was))
2307 (custom-assert '(prog1 field (setq custom-field-was nil)))
2308 ;; Prevent mixing fields properties.
2309 (custom-put-text-property begin end 'custom-field field)
2310 ;; Update the field after modification.
2311 (if (eq (custom-field-property begin) field)
2312 (let ((field-end (custom-field-end field)))
2313 (if (> end field-end)
2314 (set-marker field-end end))
2315 (add-to-list 'custom-field-changed field))
2316 ;; We deleted the entire field, reinsert it.
2317 (custom-assert '(eq begin end))
2318 (save-excursion
2319 (goto-char begin)
2320 (custom-field-value-set field
2321 (custom-read (custom-field-custom field) ""))
2322 (custom-field-insert field))))))
2324 (defun custom-field-property (pos)
2325 ;; The `custom-field' text property valid for POS.
2326 (or (get-text-property pos 'custom-field)
2327 (and (not (eq pos (point-min)))
2328 (get-text-property (1- pos) 'custom-field))))
2330 ;;; Generic Utilities:
2331 ;;
2332 ;; Some utility functions that are not really specific to custom.
2334 (defun custom-assert (expr)
2335 "Assert that EXPR evaluates to non-nil at this point"
2336 (or (eval expr)
2337 (error "Assertion failed: %S" expr)))
2339 (defun custom-first-line (string)
2340 "Return the part of STRING before the first newline."
2341 (let ((pos 0)
2342 (len (length string)))
2344 (setq pos (1+ pos)))
2345 (if (eq pos len)
2346 string
2347 (substring string 0 pos))))
2349 (defun custom-insert-before (list old new)
2350 "In LIST insert before OLD a NEW element."
2351 (cond ((null list)
2352 (list new))
2353 ((null old)
2354 (nconc list (list new)))
2355 ((eq old (car list))
2356 (cons new list))
2357 (t
2358 (let ((list list))
2359 (while (not (eq old (car (cdr list))))
2360 (setq list (cdr list))
2361 (custom-assert '(cdr list)))
2362 (setcdr list (cons new (cdr list))))
2363 list)))
2365 (defun custom-strip-padding (string padding)
2366 "Remove padding from STRING."
2367 (let ((regexp (concat (regexp-quote (char-to-string padding)) "+")))
2368 (while (string-match regexp string)
2369 (setq string (concat (substring string 0 (match-beginning 0))
2370 (substring string (match-end 0))))))
2371 string)
2373 (defun custom-plist-memq (prop plist)
2374 "Return non-nil if PROP is a property of PLIST. Comparison done with EQ."
2375 (let (result)
2376 (while plist
2377 (if (eq (car plist) prop)
2378 (setq result plist
2379 plist nil)
2380 (setq plist (cdr (cdr plist)))))
2381 result))
2383 (defun custom-plist-delq (prop plist)
2384 "Delete property PROP from property list PLIST."
2385 (while (eq (car plist) prop)
2386 (setq plist (cdr (cdr plist))))
2387 (let ((list plist)
2388 (next (cdr (cdr plist))))
2389 (while next
2390 (if (eq (car next) prop)
2391 (progn
2392 (setq next (cdr (cdr next)))
2393 (setcdr (cdr list) next))
2394 (setq list next
2395 next (cdr (cdr next))))))
2396 plist)
2398 ;;; Meta Customization:
2400 (custom-declare '()
2401 '((tag . "Meta Customization")
2402 (doc . "Customization of the customization support.")
2403 (type . group)
2404 (data ((type . face-doc))
2405 ((tag . "Button Face")
2406 (default . bold)
2407 (doc . "Face used for tags in customization buffers.")
2408 (name . custom-button-face)
2409 (synchronize . (lambda (f)
2410 (custom-category-put 'custom-button-properties
2411 'face custom-button-face)))
2412 (type . face))
2413 ((tag . "Mouse Face")
2414 (default . highlight)
2415 (doc . "\
2416 Face used when mouse is above a button in customization buffers.")
2417 (name . custom-mouse-face)
2418 (synchronize . (lambda (f)
2419 (custom-category-put 'custom-button-properties
2420 mouse-face
2421 custom-mouse-face)))
2422 (type . face))
2423 ((tag . "Field Face")
2424 (default . italic)
2425 (doc . "Face used for customization fields.")
2426 (name . custom-field-face)
2427 (type . face))
2428 ((tag . "Uninitialized Face")
2429 (default . modeline)
2430 (doc . "Face used for uninitialized customization fields.")
2431 (name . custom-field-uninitialized-face)
2432 (type . face))
2433 ((tag . "Invalid Face")
2434 (default . highlight)
2435 (doc . "\
2436 Face used for customization fields containing invalid data.")
2437 (name . custom-field-invalid-face)
2438 (type . face))
2439 ((tag . "Modified Face")
2440 (default . bold-italic)
2441 (doc . "Face used for modified customization fields.")
2442 (name . custom-field-modified-face)
2443 (type . face))
2444 ((tag . "Active Face")
2445 (default . underline)
2446 (doc . "\
2447 Face used for customization fields while they are being edited.")
2448 (name . custom-field-active-face)
2449 (type . face)))))
2451 ;; custom.el uses two categories.
2453 (custom-category-create 'custom-documentation-properties)
2454 (custom-category-put 'custom-documentation-properties rear-nonsticky t)
2456 (custom-category-create 'custom-button-properties)
2457 (custom-category-put 'custom-button-properties 'face custom-button-face)
2458 (custom-category-put 'custom-button-properties mouse-face custom-mouse-face)
2459 (custom-category-put 'custom-button-properties rear-nonsticky t)
2461 (custom-category-create 'custom-hidden-properties)
2462 (custom-category-put 'custom-hidden-properties 'invisible
2463 (not (string-match "XEmacs" emacs-version)))
2464 (custom-category-put 'custom-hidden-properties intangible t)
2466 (if (file-readable-p custom-file)
2467 (load-file custom-file))
2469 (provide 'custom)
2471 ;;; custom.el ends here