| blob | cb566cf8fe75594a34e5ab654ef888691143fd22 |
1 ;;; custom.el --- User friendly customization support.
3 ;; Copyright (C) 1995 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 ;; See `custom-match'.
528 ;; A `const' only matches a single lisp value.
535 ;; A variable containing a face.
537 You can customize the look of Emacs by deciding which faces should be
538 used when. If you push one of the face buttons below, you will be
539 given a choice between a number of standard faces. The name of the
540 selected face is shown right after the face button, and it is
541 displayed its own face so you can see how it looks. If you know of
542 another standard face not listed and want to use it, you can select
543 `Other' and write the name in the editing field.
545 If none of the standard faces suits you, you can select `Customize' to
546 create your own face. This will make six fields appear under the face
547 button. The `Fg' and `Bg' fields are the foreground and background
548 colors for the face, respectively. You should type the name of the
549 color in the field. You can use any X11 color name. A list of X11
550 color names may be available in the file `/usr/lib/X11/rgb.txt' on
551 your system. The special color name `default' means that the face
552 will not change the color of the text. The `Stipple' field is weird,
553 so just ignore it. The three remaining fields are toggles, which will
554 make the text `bold', `italic', or `underline' respectively. For some
626 " "
630 " "
636 nil nil nil))
643 ;; A string containing a file or directory name.
648 ;; Any lisp expression.
654 ;; A lisp symbol.
658 ;; A lisp integer.
662 ;; A lisp string.
668 ;; Push me.
674 ;; A documentation only entry with no value.
710 "Alist of default properties for type symbols.
714 "Local type properties.
726 "Extract from CUSTOM property PROPERTY."
729 ;; Look in superclass.
738 "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass."
741 ;; Look in superclass.
750 "Set CUSTOM PROPERTY to VALUE by side effect.
751 CUSTOM must have at least one property already."
758 "Extract `type' from CUSTOM."
762 "Extract `name' from CUSTOM."
766 "Extract `tag' from CUSTOM."
770 "Extract `face-tag' from CUSTOM."
774 "Extract `prompt' from CUSTOM.
775 If none exist, default to `tag' or, failing that, `type'."
781 "Extract `default' from CUSTOM."
788 "Extract the `data' from CUSTOM."
792 "Extract `doc' from CUSTOM."
796 "Extract `width' from CUSTOM."
800 "Extract `compact' from CUSTOM."
804 "Extract `padding' from CUSTOM."
808 "Non-nil if CUSTOM may validly be set to VALUE."
813 "Import CUSTOM VALUE from external variable.
815 This function change VALUE into a form that makes it easier to edit
816 internally. What the internal form is exactly depends on CUSTOM.
817 The internal form is returned."
823 "Return non-nil if CUSTOM's VALUE needs to be evaluated."
827 "Quote CUSTOM's VALUE if necessary."
831 "Convert CUSTOM VALUE to a string."
840 "Convert CUSTOM field content STRING into lisp."
846 "Match CUSTOM with a list of VALUES.
848 Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
849 and the cdr is the remaining VALUES.
851 A CUSTOM is actually a regular expression over the alphabet of lisp
852 types. Most CUSTOM types are just doing a literal match, e.g. the
853 `symbol' type matches any lisp symbol. The exceptions are:
855 group: which corresponds to a `(' and `)' group in a regular expression.
856 choice: which corresponds to a group of `|' in a regular expression.
857 repeat: which corresponds to a `*' in a regular expression.
858 optional: which corresponds to a `?', and isn't implemented yet."
860 ;; Nothing matches the uninitialized or empty list.
865 "Initialize `doc' and `default' attributes of CUSTOM."
869 "Find child in CUSTOM with `tag' TAG."
873 "Find decedent of CUSTOM by looking through PATH."
875 custom
879 "Extract CUSTOM's value in FIELD."
881 nil
883 custom field)))
886 "Validate CUSTOM's value in FIELD.
887 Return nil if valid, otherwise return a cons-cell where the car is the
888 position of the error, and the cdr is a text describing the error."
890 nil
893 ;;; Field Functions:
894 ;;
895 ;; This section defines the public functions for manipulating the
896 ;; FIELD datatype. The FIELD instance hold information about a
897 ;; specific editing field in the customization buffer.
898 ;;
899 ;; Each FIELD can be seen as an instantiation of a CUSTOM.
902 ;; Last field containing point.
906 ;; List of modified fields.
910 "Create a field structure of type CUSTOM containing VALUE.
912 A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
913 CUSTOM defines the type of the field,
914 VALUE is the current value of the field,
915 ORIGINAL is the original value when created, and
916 START and END are markers to the start and end of the field."
920 "Return the `custom' attribute of FIELD."
924 "Return the `value' attribute of FIELD."
928 "Return the `original' attribute of FIELD."
932 "Return the `start' attribute of FIELD."
936 "Return the `end' attribute of FIELD."
940 "Set the `value' attribute of FIELD to VALUE."
944 "Set the `original' attribute of FIELD to ORIGINAL."
948 "Set the `start'and `end' attributes of FIELD to START and END."
953 "Query user for content of current field."
957 "Store a new value into field FIELD, taking it from VALUE.
958 If optional ORIGINAL is non-nil, consider VALUE for the original value."
961 field value original)))
964 "The face used for highlighting FIELD."
967 nil
972 "Update the screen appearance of FIELD to correspond with the field's value."
975 nil
978 ;;; Types:
979 ;;
980 ;; The following functions defines type specific actions.
983 "Non-nil if CUSTOM's VALUE needs to be evaluated."
985 nil
989 value))))
992 "A list of CUSTOM's VALUEs quoted."
995 value))))
999 "Modify CUSTOM's VALUE to match internal expectations."
1002 value))))
1005 "Store a new value into field FIELD, taking it from VALUE."
1009 current new)
1016 ;; Change existing field.
1019 ;; Insert new field if series has grown.
1026 ;; Delete old field if series has scrunk.
1030 data)
1042 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1054 field))
1057 "Insert entry at point in the REPEAT field."
1068 field)
1082 field))
1085 "Add list entry."
1089 new)
1094 field new))))
1097 "Delete list entry."
1110 "Match CUSTOM with VALUES."
1113 matches)
1121 "Extract list of children's values."
1124 result)
1126 ()
1130 result))
1133 "Validate children."
1136 result)
1142 result))
1145 "Store a new value into field FIELD, taking it from VALUE."
1149 "Non-nil if CUSTOM's VALUE needs to be evaluated."
1153 "Modify CUSTOM's VALUE to match internal expectations."
1160 "Quote CUSTOM's VALUE if necessary."
1168 "Extract cons of children's values."
1171 result)
1182 "Quote CUSTOM's VALUE if necessary."
1189 "Extract list of children's values."
1192 result)
1203 "Validate children."
1206 result)
1214 result))
1217 "Non-nil if CUSTOM's VALUE needs to be evaluated."
1226 found))
1229 "A list of CUSTOM's VALUE members, quoted."
1233 ()
1240 "Modify CUSTOM's VALUE to match internal expectations."
1244 ()
1251 "Initialize `doc' and `default' entries in CUSTOM."
1257 "Reset `value' in FIELD to `original'."
1265 "Reset `value' in FIELD to `original'."
1273 "Reset `value' in FIELD to `default'."
1281 "Find child in CUSTOM with `tag' TAG."
1291 "Store a new value into field FIELD, taking it from VALUE."
1296 current)
1312 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1314 fields hidden
1326 fields))
1336 field))
1339 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1346 field))
1349 "Store a new value into field FIELD, taking it from VALUE."
1356 from)
1374 found begin)
1381 ()
1394 "Extract child's value."
1399 "Validate child's value."
1408 "Choose a child."
1414 current alist)
1427 last-input-event tag
1429 alist)))
1435 " (default "
1436 default
1438 alist nil t)))
1446 "Prompt for a file name"
1461 ""
1462 directory)
1463 default nil value)
1467 "Return non-nil if CUSTOM's VALUE needs to be evaluated."
1471 "Modify CUSTOM's VALUE to match internal expectations."
1475 name)
1483 value))))
1486 "Lookup or create a face with specified attributes.
1487 FG BG STIPPLE BOLD ITALIC UNDERLINE"
1492 bold italic underline))))
1495 ()
1501 bold italic underline))
1502 name))
1505 "Face that should be used for highlighting FIELD containing VALUE."
1508 custom value))))
1512 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1519 rear-nonsticky t))
1522 field))
1525 "Update face of FIELD."
1532 "Non-nil if CUSTOM can validly have the value VALUE."
1536 "Face used for a FIELD."
1540 "Read from CUSTOM an STRING."
1557 "Write CUSTOM SEXP as string."
1560 string
1566 "Read string by ignoring trailing padding characters."
1575 "Write raw string."
1576 string)
1579 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1583 nil)
1586 ;; Convert CUSTOM's VALUE to external representation.
1587 ;; See `custom-import'.
1590 value))
1593 "Quote CUSTOM's VALUE if necessary."
1596 value
1599 value
1602 value)))
1605 "Initialize `doc' and `default' entries in CUSTOM."
1608 ()
1622 "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1626 ()
1631 field))
1634 "Store a new value into field FIELD, taking it from VALUE."
1641 "Apply any changes in FIELD since the last apply."
1650 "Reset content of editing FIELD to `original'."
1654 "Reset content of editing FIELD to `default'."
1661 "Prompt for a FIELD"
1673 "Match CUSTOM with VALUES."
1674 values)
1677 "Extract CUSTOM's content in FIELD."
1681 "Validate FIELD."
1689 nil)
1694 "Face used for a FIELD."
1697 custom-field-uninitialized-face)
1699 custom-field-invalid-face)
1701 custom-field-modified-face)
1703 custom-field-face))))
1706 "Update the content of FIELD."
1713 ;; Keep track of how many modified fields we have.
1719 ;; Update the field.
1732 ;;; Create Buffer:
1733 ;;
1734 ;; Public functions to create a customization buffer and to insert
1735 ;; various forms of text, fields, and buttons in it.
1738 "Customize GNU Emacs.
1739 Create a *Customize* buffer with editable customization information
1740 about GNU Emacs."
1746 "Create a customization buffer named NAME.
1747 If the optional argument CUSTOM is non-nil, use that as the custom declaration.
1748 If the optional argument TYPES is non-nil, use that as the local types.
1749 If the optional argument SET is non-nil, use that to set external data.
1750 If the optional argument GET is non-nil, use that to get external data.
1751 If the optional argument SAVE is non-nil, use that for saving changes."
1757 ()
1761 ()
1765 ()
1769 ()
1794 "Insert custom declaration CUSTOM in current buffer at level LEVEL."
1798 nil)
1806 field)))
1809 "Insert TEXT in current buffer."
1813 "Insert TAG for FIELD in current buffer."
1822 "Insert documentation from CUSTOM in current buffer."
1825 ()
1829 "Insert ARGS as documentation text."
1835 "Describe how to execute COMMAND."
1840 mouse-face custom-mouse-face
1846 ;;; Mode:
1847 ;;
1848 ;; The Customization major mode and interactive commands.
1853 nil
1855 (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button)
1859 (define-key custom-mode-map "\C-k" 'custom-kill-line)
1860 (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
1861 (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
1862 (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset)
1863 (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all)
1864 (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
1865 (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
1866 (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit)
1867 (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
1869 ;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
1870 ;; forward-field, C-b backward-field, C-n next-field, C-p
1871 ;; previous-field, ? describe-field.
1873 (defun custom-mode ()
1874 "Major mode for doing customizations.
1877 (kill-all-local-variables)
1878 (setq major-mode 'custom-mode
1879 mode-name "Custom")
1880 (use-local-map custom-mode-map)
1881 (make-local-variable 'before-change-functions)
1882 (setq before-change-functions '(custom-before-change))
1883 (make-local-variable 'after-change-functions)
1884 (setq after-change-functions '(custom-after-change))
1885 (if (not (fboundp 'make-local-hook))
1886 ;; Emacs 19.28 and earlier.
1887 (add-hook 'post-command-hook
1888 (lambda ()
1889 (if (eq major-mode 'custom-mode)
1890 (custom-post-command))))
1891 ;; Emacs 19.29.
1892 (make-local-hook 'post-command-hook)
1893 (add-hook 'post-command-hook 'custom-post-command nil t)))
1895 (defun custom-forward-field (arg)
1896 "Move point to the next field or button.
1897 With optional ARG, move across that many fields."
1898 (interactive "p")
1899 (while (> arg 0)
1900 (let ((next (if (get-text-property (point) 'custom-tag)
1901 (next-single-property-change (point) 'custom-tag)
1902 (point))))
1903 (setq next (or (next-single-property-change next 'custom-tag)
1904 (next-single-property-change (point-min) 'custom-tag)))
1905 (if next
1906 (goto-char next)
1907 (error "No customization fields in this buffer.")))
1908 (or (get-text-property (point) 'custom-jump)
1909 (setq arg (1- arg))))
1910 (while (< arg 0)
1911 (let ((previous (if (get-text-property (1- (point)) 'custom-tag)
1912 (previous-single-property-change (point) 'custom-tag)
1913 (point))))
1914 (setq previous
1915 (or (previous-single-property-change previous 'custom-tag)
1916 (previous-single-property-change (point-max) 'custom-tag)))
1917 (if previous
1918 (goto-char previous)
1919 (error "No customization fields in this buffer.")))
1920 (or (get-text-property (1- (point)) 'custom-jump)
1921 (setq arg (1+ arg)))))
1923 (defun custom-backward-field (arg)
1924 "Move point to the previous field or button.
1925 With optional ARG, move across that many fields."
1926 (interactive "p")
1927 (custom-forward-field (- arg)))
1929 (defun custom-toggle-documentation (&optional arg)
1930 "Toggle display of documentation text.
1931 If the optional argument is non-nil, show text iff the argument is positive."
1932 (interactive "P")
1933 (let ((hide (or (and (null arg)
1934 (null (custom-category-get
1935 'custom-documentation-properties 'invisible)))
1936 (<= (prefix-numeric-value arg) 0))))
1937 (custom-category-put 'custom-documentation-properties 'invisible hide)
1938 (custom-category-put 'custom-documentation-properties intangible hide))
1939 (redraw-display))
1941 (defun custom-enter-value (field data)
1942 "Enter value for current customization field or push button."
1943 (interactive (list (get-text-property (point) 'custom-tag)
1944 (get-text-property (point) 'custom-data)))
1945 (cond (data
1946 (funcall field data))
1947 ((eq field 'custom-enter-value)
1948 (error "Don't be silly"))
1949 ((and (symbolp field) (fboundp field))
1950 (call-interactively field))
1951 (field
1952 (custom-field-query field))
1953 (t
1954 (message "Nothing to enter here"))))
1956 (defun custom-kill-line ()
1957 "Kill to end of field or end of line, whichever is first."
1958 (interactive)
1959 (let ((field (get-text-property (point) 'custom-field))
1961 (next (next-single-property-change (point) 'custom-field)))
1962 (if (and field (> newline next))
1963 (kill-region (point) next)
1964 (call-interactively 'kill-line))))
1966 (defun custom-push-button (event)
1967 "Activate button below mouse pointer."
1968 (interactive "@e")
1969 (let* ((pos (event-point event))
1970 (field (get-text-property pos 'custom-field))
1971 (tag (get-text-property pos 'custom-tag))
1972 (data (get-text-property pos 'custom-data)))
1973 (cond (data
1974 (funcall tag data))
1975 ((and (symbolp tag) (fboundp tag))
1976 (call-interactively tag))
1977 (field
1978 (call-interactively (lookup-key global-map (this-command-keys))))
1979 (tag
1980 (custom-enter-value tag data))
1981 (t
1982 (error "Nothing to click on here.")))))
1984 (defun custom-reset-all ()
1985 "Undo any changes since the last apply in all fields."
1986 (interactive (and custom-modified-list
1987 (not (y-or-n-p "Discard all changes? "))
1988 (error "Reset aborted")))
1989 (let ((all custom-name-fields)
1990 current field)
1991 (while all
1992 (setq current (car all)
1993 field (cdr current)
1994 all (cdr all))
1995 (custom-field-reset field))))
1997 (defun custom-field-reset (field)
1998 "Undo any changes in FIELD since the last apply."
1999 (interactive (list (or (get-text-property (point) 'custom-field)
2000 (get-text-property (point) 'custom-tag))))
2001 (if (arrayp field)
2002 (let* ((custom (custom-field-custom field))
2003 (name (custom-name custom)))
2004 (save-excursion
2005 (if name
2006 (custom-field-original-set
2007 field (car (custom-import custom (custom-external name)))))
2008 (if (not (custom-valid custom (custom-field-original field)))
2009 (error "This field cannot be reset alone")
2010 (funcall (custom-property custom 'reset) field)
2011 (funcall (custom-property custom 'synchronize) field))))))
2013 (defun custom-factory-reset-all ()
2014 "Reset all field to their default values."
2015 (interactive (and custom-modified-list
2016 (not (y-or-n-p "Discard all changes? "))
2017 (error "Reset aborted")))
2018 (let ((all custom-name-fields)
2019 field)
2020 (while all
2021 (setq field (cdr (car all))
2022 all (cdr all))
2023 (custom-field-factory-reset field))))
2025 (defun custom-field-factory-reset (field)
2026 "Reset FIELD to its default value."
2027 (interactive (list (or (get-text-property (point) 'custom-field)
2028 (get-text-property (point) 'custom-tag))))
2029 (if (arrayp field)
2030 (save-excursion
2031 (funcall (custom-property (custom-field-custom field) 'factory-reset)
2032 field))))
2034 (defun custom-apply-all ()
2035 "Apply any changes since the last reset in all fields."
2036 (interactive (if custom-modified-list
2037 nil
2038 (error "No changes to apply.")))
2039 (custom-field-parse custom-field-last)
2040 (let ((all custom-name-fields)
2041 field)
2042 (while all
2043 (setq field (cdr (car all))
2044 all (cdr all))
2045 (let ((error (custom-field-validate (custom-field-custom field) field)))
2046 (if (null error)
2047 ()
2048 (goto-char (car error))
2049 (error (cdr error))))))
2050 (let ((all custom-name-fields)
2051 field)
2052 (while all
2053 (setq field (cdr (car all))
2054 all (cdr all))
2055 (custom-field-apply field))))
2057 (defun custom-field-apply (field)
2058 "Apply any changes in FIELD since the last apply."
2059 (interactive (list (or (get-text-property (point) 'custom-field)
2060 (get-text-property (point) 'custom-tag))))
2061 (custom-field-parse custom-field-last)
2062 (if (arrayp field)
2063 (let* ((custom (custom-field-custom field))
2064 (error (custom-field-validate custom field)))
2065 (if error
2066 (error (cdr error)))
2067 (funcall (custom-property custom 'apply) field))))
2069 (defun custom-toggle-hide (&rest ignore)
2070 "Hide or show entry."
2071 (interactive)
2072 (error "This button is not yet implemented"))
2074 (defun custom-save-and-exit ()
2075 "Save and exit customization buffer."
2076 (interactive "@")
2077 (save-excursion
2078 (funcall custom-save))
2079 (kill-buffer (current-buffer)))
2081 (defun custom-save ()
2082 "Save customization information."
2083 (interactive)
2084 (custom-apply-all)
2085 (let ((new custom-name-fields))
2086 (set-buffer (find-file-noselect custom-file))
2087 (goto-char (point-min))
2088 (save-excursion
2089 (let ((old (condition-case nil
2090 (read (current-buffer))
2091 (end-of-file (append '(setq custom-dummy
2092 'custom-dummy) ())))))
2093 (or (eq (car old) 'setq)
2094 (error "Invalid customization file: %s" custom-file))
2095 (while new
2096 (let* ((field (cdr (car new)))
2097 (custom (custom-field-custom field))
2098 (value (custom-field-original field))
2099 (default (car (custom-import custom (custom-default custom))))
2100 (name (car (car new))))
2101 (setq new (cdr new))
2102 (custom-assert '(eq name (custom-name custom)))
2103 (if (equal default value)
2104 (setcdr old (custom-plist-delq name (cdr old)))
2105 (setcdr old (plist-put (cdr old) name
2106 (car (custom-quote custom value)))))))
2107 (erase-buffer)
2108 (insert ";; " custom-file "\
2109 --- Automatically generated customization information.
2110 ;;
2111 ;; Feel free to edit by hand, but the entire content should consist of
2112 ;; a single setq. Any other lisp expressions will confuse the
2113 ;; automatic configuration engine.
2115 \(setq ")
2116 (setq old (cdr old))
2117 (while old
2118 (prin1 (car old) (current-buffer))
2119 (setq old (cdr old))
2120 (insert " ")
2121 (pp (car old) (current-buffer))
2122 (setq old (cdr old))
2125 (save-buffer)
2126 (kill-buffer (current-buffer))))))
2128 (defun custom-load ()
2129 "Save customization information."
2130 (interactive (and custom-modified-list
2131 (not (equal (list (custom-name-field 'custom-file))
2132 custom-modified-list))
2133 (not (y-or-n-p "Discard all changes? "))
2134 (error "Load aborted")))
2135 (load-file (custom-name-value 'custom-file))
2136 (custom-reset-all))
2138 ;;; Field Editing:
2139 ;;
2140 ;; Various internal functions for implementing the direct editing of
2141 ;; fields in the customization buffer.
2143 (defun custom-field-untouch (field)
2144 ;; Remove FIELD and its children from `custom-modified-list'.
2145 (setq custom-modified-list (delq field custom-modified-list))
2146 (if (arrayp field)
2147 (let ((value (custom-field-value field)))
2148 (cond ((null (custom-data (custom-field-custom field))))
2149 ((arrayp value)
2150 (custom-field-untouch value))
2151 ((listp value)
2152 (mapcar 'custom-field-untouch value))))))
2155 (defun custom-field-insert (field)
2156 ;; Insert editing FIELD in current buffer.
2157 (let ((from (point))
2158 (custom (custom-field-custom field))
2159 (value (custom-field-value field)))
2160 (insert (custom-write custom value))
2161 (insert-char (custom-padding custom)
2162 (- (custom-width custom) (- (point) from)))
2163 (custom-field-move field from (point))
2164 (set-text-properties
2165 from (point)
2166 (list 'custom-field field
2167 'custom-tag field
2168 'face (custom-field-face field)
2169 front-sticky t))))
2171 (defun custom-field-read (field)
2172 ;; Read the screen content of FIELD.
2173 (custom-read (custom-field-custom field)
2174 (buffer-substring-no-properties (custom-field-start field)
2175 (custom-field-end field))))
2177 ;; Fields are shown in a special `active' face when point is inside
2178 ;; it. You activate the field by moving point inside (entering) it
2179 ;; and deactivate the field by moving point outside (leaving) it.
2181 (defun custom-field-leave (field)
2182 ;; Deactivate FIELD.
2183 (let ((before-change-functions nil)
2184 (after-change-functions nil))
2185 (put-text-property (custom-field-start field) (custom-field-end field)
2186 'face (custom-field-face field))))
2188 (defun custom-field-enter (field)
2189 ;; Activate FIELD.
2190 (let* ((start (custom-field-start field))
2191 (end (custom-field-end field))
2192 (custom (custom-field-custom field))
2193 (padding (custom-padding custom))
2194 (before-change-functions nil)
2195 (after-change-functions nil))
2196 (or (eq this-command 'self-insert-command)
2197 (let ((pos end))
2198 (while (and (< start pos)
2199 (eq (char-after (1- pos)) padding))
2200 (setq pos (1- pos)))
2201 (if (< pos (point))
2202 (goto-char pos))))
2203 (put-text-property start end 'face custom-field-active-face)))
2205 (defun custom-field-resize (field)
2206 ;; Resize FIELD after change.
2207 (let* ((custom (custom-field-custom field))
2208 (begin (custom-field-start field))
2209 (end (custom-field-end field))
2210 (pos (point))
2211 (padding (custom-padding custom))
2212 (width (custom-width custom))
2213 (size (- end begin)))
2214 (cond ((< size width)
2215 (goto-char end)
2216 (if (fboundp 'insert-before-markers-and-inherit)
2217 ;; Emacs 19.
2218 (insert-before-markers-and-inherit
2219 (make-string (- width size) padding))
2220 ;; XEmacs: BUG: Doesn't work!
2221 (insert-before-markers (make-string (- width size) padding)))
2222 (goto-char pos))
2223 ((> size width)
2224 (let ((start (if (and (< (+ begin width) pos) (<= pos end))
2225 pos
2226 (+ begin width))))
2227 (goto-char end)
2228 (while (and (< start (point)) (= (preceding-char) padding))
2229 (backward-delete-char 1))
2230 (goto-char pos))))))
2232 (defvar custom-field-changed nil)
2233 ;; List of fields changed on the screen but whose VALUE attribute has
2234 ;; not yet been updated to reflect the new screen content.
2235 (make-variable-buffer-local 'custom-field-changed)
2237 (defun custom-field-parse (field)
2238 ;; Parse FIELD content iff changed.
2239 (if (memq field custom-field-changed)
2240 (progn
2241 (setq custom-field-changed (delq field custom-field-changed))
2242 (custom-field-value-set field (custom-field-read field))
2243 (custom-field-update field))))
2245 (defun custom-post-command ()
2246 ;; Keep track of their active field.
2247 (custom-assert '(eq major-mode 'custom-mode))
2248 (let ((field (custom-field-property (point))))
2249 (if (eq field custom-field-last)
2250 (if (memq field custom-field-changed)
2251 (custom-field-resize field))
2252 (custom-field-parse custom-field-last)
2253 (if custom-field-last
2254 (custom-field-leave custom-field-last))
2255 (if field
2256 (custom-field-enter field))
2257 (setq custom-field-last field))
2258 (set-buffer-modified-p (or custom-modified-list
2259 custom-field-changed))))
2261 (defvar custom-field-was nil)
2262 ;; The custom data before the change.
2263 (make-variable-buffer-local 'custom-field-was)
2265 (defun custom-before-change (begin end)
2266 ;; Check that we the modification is allowed.
2267 (if (not (eq major-mode 'custom-mode))
2268 (message "Aargh! Why is custom-before-change called here?")
2269 (let ((from (custom-field-property begin))
2270 (to (custom-field-property end)))
2271 (cond ((or (null from) (null to))
2272 (error "You can only modify the fields"))
2273 ((not (eq from to))
2274 (error "Changes must be limited to a single field."))
2275 (t
2276 (setq custom-field-was from))))))
2278 (defun custom-after-change (begin end length)
2279 ;; Keep track of field content.
2280 (if (not (eq major-mode 'custom-mode))
2281 (message "Aargh! Why is custom-after-change called here?")
2282 (let ((field custom-field-was))
2283 (custom-assert '(prog1 field (setq custom-field-was nil)))
2284 ;; Prevent mixing fields properties.
2285 (put-text-property begin end 'custom-field field)
2286 ;; Update the field after modification.
2287 (if (eq (custom-field-property begin) field)
2288 (let ((field-end (custom-field-end field)))
2289 (if (> end field-end)
2290 (set-marker field-end end))
2291 (add-to-list 'custom-field-changed field))
2292 ;; We deleted the entire field, reinsert it.
2293 (custom-assert '(eq begin end))
2294 (save-excursion
2295 (goto-char begin)
2296 (custom-field-value-set field
2297 (custom-read (custom-field-custom field) ""))
2298 (custom-field-insert field))))))
2300 (defun custom-field-property (pos)
2301 ;; The `custom-field' text property valid for POS.
2302 (or (get-text-property pos 'custom-field)
2303 (and (not (eq pos (point-min)))
2304 (get-text-property (1- pos) 'custom-field))))
2306 ;;; Generic Utilities:
2307 ;;
2308 ;; Some utility functions that are not really specific to custom.
2310 (defun custom-assert (expr)
2311 "Assert that EXPR evaluates to non-nil at this point"
2312 (or (eval expr)
2313 (error "Assertion failed: %S" expr)))
2315 (defun custom-first-line (string)
2316 "Return the part of STRING before the first newline."
2317 (let ((pos 0)
2318 (len (length string)))
2320 (setq pos (1+ pos)))
2321 (if (eq pos len)
2322 string
2323 (substring string 0 pos))))
2325 (defun custom-insert-before (list old new)
2326 "In LIST insert before OLD a NEW element."
2327 (cond ((null list)
2328 (list new))
2329 ((null old)
2330 (nconc list (list new)))
2331 ((eq old (car list))
2332 (cons new list))
2333 (t
2334 (let ((list list))
2335 (while (not (eq old (car (cdr list))))
2336 (setq list (cdr list))
2337 (custom-assert '(cdr list)))
2338 (setcdr list (cons new (cdr list))))
2339 list)))
2341 (defun custom-strip-padding (string padding)
2342 "Remove padding from STRING."
2343 (let ((regexp (concat (regexp-quote (char-to-string padding)) "+")))
2344 (while (string-match regexp string)
2345 (setq string (concat (substring string 0 (match-beginning 0))
2346 (substring string (match-end 0))))))
2347 string)
2349 (defun custom-plist-memq (prop plist)
2350 "Return non-nil if PROP is a property of PLIST. Comparison done with EQ."
2351 (let (result)
2352 (while plist
2353 (if (eq (car plist) prop)
2354 (setq result plist
2355 plist nil)
2356 (setq plist (cdr (cdr plist)))))
2357 result))
2359 (defun custom-plist-delq (prop plist)
2360 "Delete property PROP from property list PLIST."
2361 (while (eq (car plist) prop)
2362 (setq plist (cdr (cdr plist))))
2363 (let ((list plist)
2364 (next (cdr (cdr plist))))
2365 (while next
2366 (if (eq (car next) prop)
2367 (progn
2368 (setq next (cdr (cdr next)))
2369 (setcdr (cdr list) next))
2370 (setq list next
2371 next (cdr (cdr next))))))
2372 plist)
2374 ;;; Meta Customization:
2376 (custom-declare '()
2377 '((tag . "Meta Customization")
2378 (doc . "Customization of the customization support.")
2379 (type . group)
2380 (data ((type . face-doc))
2381 ((tag . "Button Face")
2382 (default . bold)
2383 (doc . "Face used for tags in customization buffers.")
2384 (name . custom-button-face)
2385 (synchronize . (lambda (f)
2386 (custom-category-put 'custom-button-properties
2387 'face custom-button-face)))
2388 (type . face))
2389 ((tag . "Mouse Face")
2390 (default . highlight)
2391 (doc . "\
2392 Face used when mouse is above a button in customization buffers.")
2393 (name . custom-mouse-face)
2394 (synchronize . (lambda (f)
2395 (custom-category-put 'custom-button-properties
2396 mouse-face
2397 custom-mouse-face)))
2398 (type . face))
2399 ((tag . "Field Face")
2400 (default . italic)
2401 (doc . "Face used for customization fields.")
2402 (name . custom-field-face)
2403 (type . face))
2404 ((tag . "Uninitialized Face")
2405 (default . modeline)
2406 (doc . "Face used for uninitialized customization fields.")
2407 (name . custom-field-uninitialized-face)
2408 (type . face))
2409 ((tag . "Invalid Face")
2410 (default . highlight)
2411 (doc . "\
2412 Face used for customization fields containing invalid data.")
2413 (name . custom-field-invalid-face)
2414 (type . face))
2415 ((tag . "Modified Face")
2416 (default . bold-italic)
2417 (doc . "Face used for modified customization fields.")
2418 (name . custom-field-modified-face)
2419 (type . face))
2420 ((tag . "Active Face")
2421 (default . underline)
2422 (doc . "\
2423 Face used for customization fields while they are being edited.")
2424 (name . custom-field-active-face)
2425 (type . face)))))
2427 ;; custom.el uses two categories.
2429 (custom-category-create 'custom-documentation-properties)
2430 (custom-category-put 'custom-documentation-properties rear-nonsticky t)
2432 (custom-category-create 'custom-button-properties)
2433 (custom-category-put 'custom-button-properties 'face custom-button-face)
2434 (custom-category-put 'custom-button-properties mouse-face custom-mouse-face)
2435 (custom-category-put 'custom-button-properties rear-nonsticky t)
2437 (custom-category-create 'custom-hidden-properties)
2438 (custom-category-put 'custom-hidden-properties 'invisible
2439 (not (string-match "XEmacs" emacs-version)))
2440 (custom-category-put 'custom-hidden-properties intangible t)
2442 (if (file-readable-p custom-file)
2443 (load-file custom-file))
2445 (provide 'custom)
2447 ;;; custom.el ends here