- (beep)
- (message "please make a choice from the menu.")))))))
-
-;;; Categories:
-;;
-;; XEmacs use inheritable extents for the same purpose as Emacs uses
-;; the category text property.
-
-(if (string-match "XEmacs" emacs-version)
- (progn
- ;; XEmacs categories.
- (defun custom-category-create (name)
- (set name (make-extent nil nil))
- "Create a text property category named NAME.")
-
- (defun custom-category-put (name property value)
- "In CATEGORY set PROPERTY to VALUE."
- (set-extent-property (symbol-value name) property value))
-
- (defun custom-category-get (name property)
- "In CATEGORY get PROPERTY."
- (extent-property (symbol-value name) property))
-
- (defun custom-category-set (from to category)
- "Make text between FROM and TWO have category CATEGORY."
- (let ((extent (make-extent from to)))
- (set-extent-parent extent (symbol-value category)))))
-
- ;; Emacs categories.
- (defun custom-category-create (name)
- "Create a text property category named NAME."
- (set name name))
-
- (defun custom-category-put (name property value)
- "In CATEGORY set PROPERTY to VALUE."
- (put name property value))
-
- (defun custom-category-get (name property)
- "In CATEGORY get PROPERTY."
- (get name property))
-
- (defun custom-category-set (from to category)
- "Make text between FROM and TWO have category CATEGORY."
- (custom-put-text-property from to 'category category)))
-
-;;; External Data:
-;;
-;; The following functions and variables defines the interface for
-;; connecting a CUSTOM with an external entity, by default an emacs
-;; lisp variable.
-
-(defvar custom-external 'default-value
- "Function returning the external value of NAME.")
-
-(defvar custom-external-set 'set-default
- "Function setting the external value of NAME to VALUE.")
-
-(defun custom-external (name)
- "Get the external value associated with NAME."
- (funcall custom-external name))
-
-(defun custom-external-set (name value)
- "Set the external value associated with NAME to VALUE."
- (funcall custom-external-set name value))
-
-(defvar custom-name-fields nil
- "Alist of custom names and their associated editing field.")
-(make-variable-buffer-local 'custom-name-fields)
-
-(defun custom-name-enter (name field)
- "Associate NAME with FIELD."
- (if (null name)
- ()
- (custom-assert 'field)
- (setq custom-name-fields (cons (cons name field) custom-name-fields))))
-
-(defun custom-name-field (name)
- "The editing field associated with NAME."
- (cdr (assq name custom-name-fields)))
-
-(defun custom-name-value (name)
- "The value currently displayed for NAME in the customization buffer."
- (let* ((field (custom-name-field name))
- (custom (custom-field-custom field)))
- (custom-field-parse field)
- (funcall (custom-property custom 'export) custom
- (car (custom-field-extract custom field)))))
-
-(defvar custom-save 'custom-save
- "Function that will save current customization buffer.")
-
-;;; Custom Functions:
-;;
-;; The following functions are part of the public interface to the
-;; CUSTOM datastructure. Each CUSTOM describes a group of variables,
-;; a single variable, or a component of a structured variable. The
-;; CUSTOM instances are part of two hierarchies, the first is the
-;; `part-of' hierarchy in which each CUSTOM is a component of another
-;; CUSTOM, except for the top level CUSTOM which is contained in
-;; `custom-data'. The second hierarchy is a `is-a' type hierarchy
-;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
-;; property and `custom-type-properties'.
-
-(defvar custom-file "~/.custom.el"
- "Name of file with customization information.")
-
-(defconst custom-data
- '((tag . "Emacs")
- (doc . "The extensible self-documenting text editor.")
- (type . group)
- (data "\n"
- ((header . nil)
- (compact . t)
- (type . group)
- (doc . "\
-Press [Save] to save any changes permanently after you are done editing.
-You can load customization information from other files by editing the
-`File' field and pressing the [Load] button. When you press [Save] the
-customization information of all files you have loaded, plus any
-changes you might have made manually, will be stored in the file
-specified by the `File' field.")
- (data ((tag . "Load")
- (type . button)
- (query . custom-load))
- ((tag . "Save")
- (type . button)
- (query . custom-save))
- ((name . custom-file)
- (default . "~/.custom.el")
- (doc . "Name of file with customization information.\n")
- (tag . "File")
- (type . file))))))
- "The global customization information.
-A custom association list.")
-
-(defun custom-declare (path custom)
- "Declare variables for customization.
-PATH is a list of tags leading to the place in the customization
-hierarchy the new entry should be added. CUSTOM is the entry to add."
- (custom-initialize custom)
- (let ((current (custom-travel-path custom-data path)))
- (or (member custom (custom-data current))
- (nconc (custom-data current) (list custom)))))
-
-(put 'custom-declare 'lisp-indent-hook 1)
-
-(defconst custom-type-properties
- '((repeat (type . default)
- ;; See `custom-match'.
- (import . custom-repeat-import)
- (eval . custom-repeat-eval)
- (quote . custom-repeat-quote)
- (accept . custom-repeat-accept)
- (extract . custom-repeat-extract)
- (validate . custom-repeat-validate)
- (insert . custom-repeat-insert)
- (match . custom-repeat-match)
- (query . custom-repeat-query)
- (prefix . "")
- (del-tag . "[DEL]")
- (add-tag . "[INS]"))
- (pair (type . group)
- ;; A cons-cell.
- (accept . custom-pair-accept)
- (eval . custom-pair-eval)
- (import . custom-pair-import)
- (quote . custom-pair-quote)
- (valid . (lambda (c d) (consp d)))
- (extract . custom-pair-extract))
- (list (type . group)
- ;; A lisp list.
- (quote . custom-list-quote)
- (valid . (lambda (c d)
- (listp d)))
- (extract . custom-list-extract))
- (group (type . default)
- ;; See `custom-match'.
- (face-tag . nil)
- (eval . custom-group-eval)
- (import . custom-group-import)
- (initialize . custom-group-initialize)
- (apply . custom-group-apply)
- (reset . custom-group-reset)
- (factory-reset . custom-group-factory-reset)
- (extract . nil)
- (validate . custom-group-validate)
- (query . custom-toggle-hide)
- (accept . custom-group-accept)
- (insert . custom-group-insert)
- (find . custom-group-find))
- (toggle (type . choice)
- ;; Booleans.
- (data ((type . const)
- (tag . "On ")
- (default . t))
- ((type . const)
- (tag . "Off")
- (default . nil))))
- (triggle (type . choice)
- ;; On/Off/Default.
- (data ((type . const)
- (tag . "On ")
- (default . t))
- ((type . const)
- (tag . "Off")
- (default . nil))
- ((type . const)
- (tag . "Def")
- (default . custom:asis))))
- (choice (type . default)
- ;; See `custom-match'.
- (query . custom-choice-query)
- (accept . custom-choice-accept)
- (extract . custom-choice-extract)
- (validate . custom-choice-validate)
- (insert . custom-choice-insert)
- (none (tag . "Unknown")
- (default . __uninitialized__)
- (type . const)))
- (const (type . default)
- ;; A `const' only matches a single lisp value.
- (extract . (lambda (c f) (list (custom-default c))))
- (validate . (lambda (c f) nil))
- (valid . custom-const-valid)
- (update . custom-const-update)
- (insert . custom-const-insert))
- (face-doc (type . doc)
- ;; A variable containing a face.
- (doc . "\
-You can customize the look of Emacs by deciding which faces should be
-used when. If you push one of the face buttons below, you will be
-given a choice between a number of standard faces. The name of the
-selected face is shown right after the face button, and it is
-displayed its own face so you can see how it looks. If you know of
-another standard face not listed and want to use it, you can select
-`Other' and write the name in the editing field.
-
-If none of the standard faces suits you, you can select `Customize' to
-create your own face. This will make six fields appear under the face
-button. The `Fg' and `Bg' fields are the foreground and background
-colors for the face, respectively. You should type the name of the
-color in the field. You can use any X11 color name. A list of X11
-color names may be available in the file `/usr/lib/X11/rgb.txt' on
-your system. The special color name `default' means that the face
-will not change the color of the text. The `Stipple' field is weird,
-so just ignore it. The three remaining fields are toggles, which will
-make the text `bold', `italic', or `underline' respectively. For some
-fonts `bold' or `italic' will not make any visible change."))
- (face (type . choice)
- (eval . custom-face-eval)
- (import . custom-face-import)
- (data ((tag . "None")
- (default . nil)
- (type . const))
- ((tag . "Default")
- (default . default)
- (face . custom-const-face)
- (type . const))
- ((tag . "Bold")
- (default . bold)
- (face . custom-const-face)
- (type . const))
- ((tag . "Bold-italic")
- (default . bold-italic)
- (face . custom-const-face)
- (type . const))
- ((tag . "Italic")
- (default . italic)
- (face . custom-const-face)
- (type . const))
- ((tag . "Underline")
- (default . underline)
- (face . custom-const-face)
- (type . const))
- ((tag . "Highlight")
- (default . highlight)
- (face . custom-const-face)
- (type . const))
- ((tag . "Modeline")
- (default . modeline)
- (face . custom-const-face)
- (type . const))
- ((tag . "Region")
- (default . region)
- (face . custom-const-face)
- (type . const))
- ((tag . "Secondary Selection")
- (default . secondary-selection)
- (face . custom-const-face)
- (type . const))
- ((tag . "Customized")
- (compact . t)
- (face-tag . custom-face-hack)
- (eval . custom-face-eval)
- (data ((hidden . t)
- (tag . "")
- (doc . "\
-Select the properties you want this face to have.")
- (default . custom-face-lookup)
- (type . const))
- "\n"
- ((tag . "Fg")
- (hidden . t)
- (default . "default")
- (width . 20)
- (type . string))
- ((tag . "Bg")
- (default . "default")
- (width . 20)
- (type . string))
- ((tag . "Stipple")
- (default . "default")
- (width . 20)
- (type . string))
- "\n"
- ((tag . "Bold")
- (default . custom:asis)
- (type . triggle))
- " "
- ((tag . "Italic")
- (default . custom:asis)
- (type . triggle))
- " "
- ((tag . "Underline")
- (hidden . t)
- (default . custom:asis)
- (type . triggle)))
- (default . (custom-face-lookup "default" "default" "default"
- nil nil nil))
- (type . list))
- ((prompt . "Other")
- (face . custom-field-value)
- (default . __uninitialized__)
- (type . symbol))))
- (file (type . string)
- ;; A string containing a file or directory name.
- (directory . nil)
- (default-file . nil)
- (query . custom-file-query))
- (sexp (type . default)
- ;; Any lisp expression.
- (width . 40)
- (default . (__uninitialized__ . "Uninitialized"))
- (read . custom-sexp-read)
- (write . custom-sexp-write))
- (symbol (type . sexp)
- ;; A lisp symbol.
- (width . 40)
- (valid . (lambda (c d) (symbolp d))))
- (integer (type . sexp)
- ;; A lisp integer.
- (width . 10)
- (valid . (lambda (c d) (integerp d))))
- (string (type . default)
- ;; A lisp string.
- (width . 40)
- (valid . (lambda (c d) (stringp d)))
- (read . custom-string-read)
- (write . custom-string-write))
- (button (type . default)
- ;; Push me.
- (accept . ignore)
- (extract . nil)
- (validate . ignore)
- (insert . custom-button-insert))
- (doc (type . default)
- ;; A documentation only entry with no value.
- (header . nil)
- (reset . ignore)
- (extract . nil)
- (validate . ignore)
- (insert . custom-documentation-insert))
- (default (width . 20)
- (valid . (lambda (c v) t))
- (insert . custom-default-insert)
- (update . custom-default-update)
- (query . custom-default-query)
- (tag . nil)
- (prompt . nil)
- (doc . nil)
- (header . t)
- (padding . ? )
- (quote . custom-default-quote)
- (eval . (lambda (c v) nil))
- (export . custom-default-export)
- (import . (lambda (c v) (list v)))
- (synchronize . ignore)
- (initialize . custom-default-initialize)
- (extract . custom-default-extract)
- (validate . custom-default-validate)
- (apply . custom-default-apply)
- (reset . custom-default-reset)
- (factory-reset . custom-default-factory-reset)
- (accept . custom-default-accept)
- (match . custom-default-match)
- (name . nil)
- (compact . nil)
- (hidden . nil)
- (face . custom-default-face)
- (data . nil)
- (calculate . nil)
- (default . __uninitialized__)))
- "Alist of default properties for type symbols.
-The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.")
-
-(defconst custom-local-type-properties nil
- "Local type properties.
-Entries in this list take precedence over `custom-type-properties'.")
-
-(make-variable-buffer-local 'custom-local-type-properties)
-
-(defconst custom-nil '__uninitialized__
- "Special value representing an uninitialized field.")
-
-(defconst custom-invalid '__invalid__
- "Special value representing an invalid field.")
-
-(defconst custom:asis 'custom:asis)
-;; Bad, ugly, and horrible kludge.
-
-(defun custom-property (custom property)
- "Extract from CUSTOM property PROPERTY."
- (let ((entry (assq property custom)))
- (while (null entry)
- ;; Look in superclass.
- (let ((type (custom-type custom)))
- (setq custom (cdr (or (assq type custom-local-type-properties)
- (assq type custom-type-properties)))
- entry (assq property custom))
- (custom-assert 'custom)))
- (cdr entry)))
-
-(defun custom-super (custom property)
- "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass."
- (let ((entry nil))
- (while (null entry)
- ;; Look in superclass.
- (let ((type (custom-type custom)))
- (setq custom (cdr (or (assq type custom-local-type-properties)
- (assq type custom-type-properties)))
- entry (assq property custom))
- (custom-assert 'custom)))
- (cdr entry)))
-
-(defun custom-property-set (custom property value)
- "Set CUSTOM PROPERTY to VALUE by side effect.
-CUSTOM must have at least one property already."
- (let ((entry (assq property custom)))
- (if entry
- (setcdr entry value)
- (setcdr custom (cons (cons property value) (cdr custom))))))
-
-(defun custom-type (custom)
- "Extract `type' from CUSTOM."
- (cdr (assq 'type custom)))
-
-(defun custom-name (custom)
- "Extract `name' from CUSTOM."
- (custom-property custom 'name))
-
-(defun custom-tag (custom)
- "Extract `tag' from CUSTOM."
- (custom-property custom 'tag))
-
-(defun custom-face-tag (custom)
- "Extract `face-tag' from CUSTOM."
- (custom-property custom 'face-tag))
-
-(defun custom-prompt (custom)
- "Extract `prompt' from CUSTOM.
-If none exist, default to `tag' or, failing that, `type'."
- (or (custom-property custom 'prompt)
- (custom-property custom 'tag)
- (capitalize (symbol-name (custom-type custom)))))
-
-(defun custom-default (custom)
- "Extract `default' from CUSTOM."
- (let ((value (custom-property custom 'calculate)))
- (if value
- (eval value)
- (custom-property custom 'default))))
-
-(defun custom-data (custom)
- "Extract the `data' from CUSTOM."
- (custom-property custom 'data))
-
-(defun custom-documentation (custom)
- "Extract `doc' from CUSTOM."
- (custom-property custom 'doc))
-
-(defun custom-width (custom)
- "Extract `width' from CUSTOM."
- (custom-property custom 'width))
-
-(defun custom-compact (custom)
- "Extract `compact' from CUSTOM."
- (custom-property custom 'compact))
-
-(defun custom-padding (custom)
- "Extract `padding' from CUSTOM."
- (custom-property custom 'padding))
-
-(defun custom-valid (custom value)
- "Non-nil if CUSTOM may validly be set to VALUE."
- (and (not (and (listp value) (eq custom-invalid (car value))))
- (funcall (custom-property custom 'valid) custom value)))
-
-(defun custom-import (custom value)
- "Import CUSTOM VALUE from external variable.
-
-This function change VALUE into a form that makes it easier to edit
-internally. What the internal form is exactly depends on CUSTOM.
-The internal form is returned."
- (if (eq custom-nil value)
- (list custom-nil)
- (funcall (custom-property custom 'import) custom value)))
-
-(defun custom-eval (custom value)
- "Return non-nil if CUSTOM's VALUE needs to be evaluated."
- (funcall (custom-property custom 'eval) custom value))
-
-(defun custom-quote (custom value)
- "Quote CUSTOM's VALUE if necessary."
- (funcall (custom-property custom 'quote) custom value))
-
-(defun custom-write (custom value)
- "Convert CUSTOM VALUE to a string."
- (cond ((eq value custom-nil)
- "")
- ((and (listp value) (eq (car value) custom-invalid))
- (cdr value))
- (t
- (funcall (custom-property custom 'write) custom value))))
-
-(defun custom-read (custom string)
- "Convert CUSTOM field content STRING into lisp."
- (condition-case nil
- (funcall (custom-property custom 'read) custom string)
- (error (cons custom-invalid string))))
-
-(defun custom-match (custom values)
- "Match CUSTOM with a list of VALUES.
-
-Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
-and the cdr is the remaining VALUES.
-
-A CUSTOM is actually a regular expression over the alphabet of lisp
-types. Most CUSTOM types are just doing a literal match, e.g. the
-`symbol' type matches any lisp symbol. The exceptions are:
-
-group: which corresponds to a `(' and `)' group in a regular expression.
-choice: which corresponds to a group of `|' in a regular expression.
-repeat: which corresponds to a `*' in a regular expression.
-optional: which corresponds to a `?', and isn't implemented yet."
- (if (memq values (list custom-nil nil))
- ;; Nothing matches the uninitialized or empty list.
- (cons custom-nil nil)
- (funcall (custom-property custom 'match) custom values)))
-
-(defun custom-initialize (custom)
- "Initialize `doc' and `default' attributes of CUSTOM."
- (funcall (custom-property custom 'initialize) custom))
-
-(defun custom-find (custom tag)
- "Find child in CUSTOM with `tag' TAG."
- (funcall (custom-property custom 'find) custom tag))
-
-(defun custom-travel-path (custom path)
- "Find decedent of CUSTOM by looking through PATH."
- (if (null path)
- custom
- (custom-travel-path (custom-find custom (car path)) (cdr path))))
-
-(defun custom-field-extract (custom field)
- "Extract CUSTOM's value in FIELD."
- (if (stringp custom)
- nil
- (funcall (custom-property (custom-field-custom field) 'extract)
- custom field)))
-
-(defun custom-field-validate (custom field)
- "Validate CUSTOM's value in FIELD.
-Return nil if valid, otherwise return a cons-cell where the car is the
-position of the error, and the cdr is a text describing the error."
- (if (stringp custom)
- nil
- (funcall (custom-property custom 'validate) custom field)))
-
-;;; Field Functions:
-;;
-;; This section defines the public functions for manipulating the
-;; FIELD datatype. The FIELD instance hold information about a
-;; specific editing field in the customization buffer.
-;;
-;; Each FIELD can be seen as an instantiation of a CUSTOM.
-
-(defvar custom-field-last nil)
-;; Last field containing point.
-(make-variable-buffer-local 'custom-field-last)
-
-(defvar custom-modified-list nil)
-;; List of modified fields.
-(make-variable-buffer-local 'custom-modified-list)
-
-(defun custom-field-create (custom value)
- "Create a field structure of type CUSTOM containing VALUE.
-
-A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
-CUSTOM defines the type of the field,
-VALUE is the current value of the field,
-ORIGINAL is the original value when created, and
-START and END are markers to the start and end of the field."
- (vector custom value custom-nil nil nil))
-
-(defun custom-field-custom (field)
- "Return the `custom' attribute of FIELD."
- (aref field 0))
-
-(defun custom-field-value (field)
- "Return the `value' attribute of FIELD."
- (aref field 1))
-
-(defun custom-field-original (field)
- "Return the `original' attribute of FIELD."
- (aref field 2))
-
-(defun custom-field-start (field)
- "Return the `start' attribute of FIELD."
- (aref field 3))
-
-(defun custom-field-end (field)
- "Return the `end' attribute of FIELD."
- (aref field 4))
-
-(defun custom-field-value-set (field value)
- "Set the `value' attribute of FIELD to VALUE."
- (aset field 1 value))
-
-(defun custom-field-original-set (field original)
- "Set the `original' attribute of FIELD to ORIGINAL."
- (aset field 2 original))
-
-(defun custom-field-move (field start end)
- "Set the `start'and `end' attributes of FIELD to START and END."
- (set-marker (or (aref field 3) (aset field 3 (make-marker))) start)
- (set-marker (or (aref field 4) (aset field 4 (make-marker))) end))
-
-(defun custom-field-query (field)
- "Query user for content of current field."
- (funcall (custom-property (custom-field-custom field) 'query) field))
-
-(defun custom-field-accept (field value &optional original)
- "Store a new value into field FIELD, taking it from VALUE.
-If optional ORIGINAL is non-nil, consider VALUE for the original value."
- (let ((inhibit-point-motion-hooks t))
- (funcall (custom-property (custom-field-custom field) 'accept)
- field value original)))