;;; custom.el --- User friendly customization support.
-;; Copyright (C) 1995 Free Software Foundation, Inc.
-;;
+
+;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: help
-;; Version: 0.2
+;; Version: 0.5
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; Commentary:
-;;
+
;; WARNING: This package is still under construction and not all of
;; the features below are implemented.
;;
;; editing a text file in some arcane syntax is user hostile in the
;; extreme, and to most users emacs lisp definitely count as arcane.
;;
-;; The intension is that authors of emacs lisp packages declare the
+;; The intent is that authors of emacs lisp packages declare the
;; variables intended for user customization with `custom-declare'.
;; Custom can then automatically generate a customization buffer with
;; `custom-buffer-create' where the user can edit the package
;;; Todo:
;;
;; - Toggle documentation in three states `none', `one-line', `full'.
-;; - Add description of faces to buffer and mode.
-;; - Function to generate a XEmacs menu from a CUSTOM.
-;; - Add support for customizing packages.
-;; - Make it possible to hide sections by clicling at the level stars.
+;; - Function to generate an XEmacs menu from a CUSTOM.
+;; - Write TeXinfo documentation.
+;; - Make it possible to hide sections by clicking at the level.
;; - Declare AUC TeX variables.
;; - Declare (ding) Gnus variables.
;; - Declare Emacs variables.
;; - Implement remaining types.
;; - XEmacs port.
+;; - Allow `URL', `info', and internal hypertext buttons.
+;; - Support meta-variables and goal directed customization.
+;; - Make it easy to declare custom types independently.
+;; - Make it possible to declare default value and type for a single
+;; variable, storing the data in a symbol property.
+;; - Syntactic sugar for CUSTOM declarations.
+;; - Use W3 for variable documentation.
;;; Code:
+(eval-when-compile
+ (require 'cl))
+
;;; Compatibility:
-(or (fboundp 'buffer-substring-no-properties)
- ;; Introduced in Emacs 19.29.
- (defun buffer-substring-no-properties (beg end)
- "Return the text from BEG to END, without text properties, as a string."
- (let ((string (buffer-substring beg end)))
- (set-text-properties 0 (length string) nil string)
- string)))
-
-(or (fboundp 'add-to-list)
- ;; Introduced in Emacs 19.29.
- (defun add-to-list (list-var element)
- "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
-If you want to use `add-to-list' on a variable that is not defined
-until a certain package is loaded, you should put the call to `add-to-list'
-into a hook function that will be run only after loading the package.
-`eval-after-load' provides one way to do this. In some cases
-other hooks, such as major mode hooks, can do the job."
- (or (member element (symbol-value list-var))
- (set list-var (cons element (symbol-value list-var))))))
-
-(defvar intangible nil
- "The symbol making text intangible")
+(defun custom-xmas-add-text-properties (start end props &optional object)
+ (add-text-properties start end props object)
+ (put-text-property start end 'start-open t object)
+ (put-text-property start end 'end-open t object))
+
+(defun custom-xmas-put-text-property (start end prop value &optional object)
+ (put-text-property start end prop value object)
+ (put-text-property start end 'start-open t object)
+ (put-text-property start end 'end-open t object))
+
+(defun custom-xmas-extent-start-open ()
+ (map-extents (lambda (extent arg)
+ (set-extent-property extent 'start-open t))
+ nil (point) (min (1+ (point)) (point-max))))
+
+(if (string-match "XEmacs\\|Lucid" emacs-version)
+ (progn
+ (fset 'custom-add-text-properties 'custom-xmas-add-text-properties)
+ (fset 'custom-put-text-property 'custom-xmas-put-text-property)
+ (fset 'custom-extent-start-open 'custom-xmas-extent-start-open)
+ (fset 'custom-set-text-properties
+ (if (fboundp 'set-text-properties)
+ 'set-text-properties))
+ (fset 'custom-buffer-substring-no-properties
+ (if (fboundp 'buffer-substring-no-properties)
+ 'buffer-substring-no-properties
+ 'custom-xmas-buffer-substring-no-properties)))
+ (fset 'custom-add-text-properties 'add-text-properties)
+ (fset 'custom-put-text-property 'put-text-property)
+ (fset 'custom-extent-start-open 'ignore)
+ (fset 'custom-set-text-properties 'set-text-properties)
+ (fset 'custom-buffer-substring-no-properties
+ 'buffer-substring-no-properties))
+
+(defun custom-xmas-buffer-substring-no-properties (beg end)
+ "Return the text from BEG to END, without text properties, as a string."
+ (let ((string (buffer-substring beg end)))
+ (custom-set-text-properties 0 (length string) nil string)
+ string))
+
+;; XEmacs and Emacs 19.29 facep does different things.
+(if (fboundp 'find-face)
+ (fset 'custom-facep 'find-face)
+ (fset 'custom-facep 'facep))
+
+(if (custom-facep 'underline)
+ ()
+ ;; No underline face in XEmacs 19.12.
+ (and (fboundp 'make-face)
+ (funcall (intern "make-face") 'underline))
+ ;; Must avoid calling set-face-underline-p directly, because it
+ ;; is a defsubst in emacs19, and will make the .elc files non
+ ;; portable!
+ (or (and (fboundp 'face-differs-from-default-p)
+ (face-differs-from-default-p 'underline))
+ (and (fboundp 'set-face-underline-p)
+ (funcall 'set-face-underline-p 'underline t))))
+
+(defun custom-xmas-set-text-properties (start end props &optional buffer)
+ (if (null buffer)
+ (if props
+ (while props
+ (custom-put-text-property
+ start end (car props) (nth 1 props) buffer)
+ (setq props (nthcdr 2 props)))
+ (remove-text-properties start end ()))))
+
+(or (fboundp 'event-point)
+ ;; Missing in Emacs 19.29.
+ (defun event-point (event)
+ "Return the character position of the given mouse-motion, button-press,
+or button-release event. If the event did not occur over a window, or did
+not occur over text, then this returns nil. Otherwise, it returns an index
+into the buffer visible in the event's window."
+ (posn-point (event-start event))))
+
+(eval-when-compile
+ (defvar x-colors nil)
+ (defvar custom-button-face nil)
+ (defvar custom-field-uninitialized-face nil)
+ (defvar custom-field-invalid-face nil)
+ (defvar custom-field-modified-face nil)
+ (defvar custom-field-face nil)
+ (defvar custom-mouse-face nil)
+ (defvar custom-field-active-face nil))
;; We can't easily check for a working intangible.
-(if (and (boundp 'emacs-minor-version)
- (or (> emacs-major-version 19)
- (and (> emacs-major-version 18)
- (> emacs-minor-version 28))))
- (setq intangible 'intangible)
- (setq intangible 'intangible-if-it-had-been-working))
-
-(defvar custom-modified-list nil)
-
-;;; Faces:
+(defconst intangible (if (and (boundp 'emacs-minor-version)
+ (or (> emacs-major-version 19)
+ (and (> emacs-major-version 18)
+ (> emacs-minor-version 28))))
+ (setq intangible 'intangible)
+ (setq intangible 'intangible-if-it-had-been-working))
+ "The symbol making text intangible.")
+
+(defconst rear-nonsticky (if (string-match "XEmacs" emacs-version)
+ 'end-open
+ 'rear-nonsticky)
+ "The symbol making text properties non-sticky in the rear end.")
+
+(defconst front-sticky (if (string-match "XEmacs" emacs-version)
+ 'front-closed
+ 'front-sticky)
+ "The symbol making text properties sticky in the front.")
+
+(defconst mouse-face (if (string-match "XEmacs" emacs-version)
+ 'highlight
+ 'mouse-face)
+ "Symbol used for highlighting text under mouse.")
+
+;; Put it in the Help menu, if possible.
+(if (string-match "XEmacs" emacs-version)
+ (if (featurep 'menubar)
+ ;; XEmacs (disabled because it doesn't work)
+ (and current-menubar
+ (add-menu-item '("Help") "Customize..." 'customize t)))
+ ;; Emacs 19.28 and earlier
+ (global-set-key [ menu-bar help customize ]
+ '("Customize..." . customize))
+ ;; Emacs 19.29 and later
+ (global-set-key [ menu-bar help-menu customize ]
+ '("Customize..." . customize)))
+
+;; XEmacs popup-menu stolen from w3.el.
+(defun custom-x-really-popup-menu (pos title menudesc)
+ "My hacked up function to do a blocking popup menu..."
+ (let ((echo-keystrokes 0)
+ event menu)
+ (while menudesc
+ (setq menu (cons (vector (car (car menudesc))
+ (list (car (car menudesc))) t) menu)
+ menudesc (cdr menudesc)))
+ (setq menu (cons title menu))
+ (popup-menu menu)
+ (catch 'popup-done
+ (while t
+ (setq event (next-command-event event))
+ (cond ((and (misc-user-event-p event) (stringp (car-safe (event-object event))))
+ (throw 'popup-done (event-object event)))
+ ((and (misc-user-event-p event)
+ (or (eq (event-object event) 'abort)
+ (eq (event-object event) 'menu-no-selection-hook)))
+ nil)
+ ((not (popup-menu-up-p))
+ (throw 'popup-done nil))
+ ((button-release-event-p event);; don't beep twice
+ nil)
+ (t
+ (beep)
+ (message "please make a choice from the menu.")))))))
+
+;;; Categories:
;;
-;; The following variables define the faces used in the customization
-;; buffer.
-
-(defvar custom-button-face 'bold
- "Face used for tags in customization buffers.")
-
-(defvar custom-field-uninitialized-face 'modeline
- "Face used for uninitialized customization fields.")
-
-(defvar custom-field-invalid-face 'highlight
- "Face used for customization fields containing invalid data.")
-
-(defvar custom-field-modified-face 'bold-italic
- "Face used for modified customization fields.")
-
-(defvar custom-field-active-face 'underline
- "Face used for customization fields while they are being edited.")
-
-(defvar custom-field-face 'italic
- "Face used for customization fields.")
-
-(defvar custom-mouse-face 'highlight
- "Face used for tags in customization buffers.")
-
-(defvar custom-documentation-properties 'custom-documentation-properties
- "The properties of this symbol will be in effect for all documentation.")
-(put custom-documentation-properties 'rear-nonsticky t)
-
-(defvar custom-button-properties 'custom-button-properties
- "The properties of this symbol will be in effect for all buttons.")
-(put custom-button-properties 'face custom-button-face)
-(put custom-button-properties 'mouse-face custom-mouse-face)
-(put custom-button-properties 'rear-nonsticky t)
+;; 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:
;;
(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 (cdr (assq name custom-name-fields))))
- (car (custom-field-extract (custom-field-custom field) field))))
+ (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 hiearachies, the first is 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 hiearachy is a `is-a' type hierarchy
+;; `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 . nil))
+ (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)
- (extract . custom-list-extract)
- (validate . custom-list-validate)
- (check . custom-list-check))
+ ;; 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 . nil)
+ (validate . custom-group-validate)
(query . custom-toggle-hide)
(accept . custom-group-accept)
- (insert . custom-group-insert))
+ (insert . custom-group-insert)
+ (find . custom-group-find))
(toggle (type . choice)
+ ;; Booleans.
(data ((type . const)
- (tag . "On")
+ (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)
- (check . custom-choice-check)
(insert . custom-choice-insert)
(none (tag . "Unknown")
(default . __uninitialized__)
(type . const)))
(const (type . default)
- (accept . ignore)
+ ;; 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))
- (integer (type . default)
+ (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)))
- (allow-padding . nil)
- (read . custom-integer-read)
- (write . custom-integer-write))
+ (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 . nil)
+ (validate . ignore)
(insert . custom-button-insert))
(doc (type . default)
- (rest . nil)
+ ;; A documentation only entry with no value.
+ (header . nil)
+ (reset . ignore)
(extract . nil)
- (validate . 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 . ? )
- (allow-padding . t)
+ (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.")
+ "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)))
(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)))
"Extract `tag' from CUSTOM."
(custom-property custom 'tag))
-(defun custom-tag-or-type (custom)
- "Extract `tag' from CUSTOM. If none exist, create one from `type'"
- (or (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."
- (custom-property custom 'default))
-
+ (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))
"Extract `padding' from CUSTOM."
(custom-property custom 'padding))
-(defun custom-allow-padding (custom)
- "Extract `allow-padding' from CUSTOM."
- (custom-property custom 'allow-padding))
-
(defun custom-valid (custom value)
- "Non-nil if CUSTOM may legally be set to VALUE."
- (funcall (custom-property 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."
- (if (eq value custom-nil)
- ""
- (funcall (custom-property custom 'write) custom value)))
+ (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 external form."
- (funcall (custom-property 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."
+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)
;; FIELD datatype. The FIELD instance hold information about a
;; specific editing field in the customization buffer.
;;
-;; Each FIELD can be seen as an instanciation of a CUSTOM.
+;; 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.
(funcall (custom-property (custom-field-custom field) 'query) field))
(defun custom-field-accept (field value &optional original)
- "Accept FIELD VALUE.
+ "Store a new value into field FIELD, taking it from VALUE.
If optional ORIGINAL is non-nil, consider VALUE for the original value."
- (funcall (custom-property (custom-field-custom field) 'accept)
- field value original))
+ (let ((inhibit-point-motion-hooks t))
+ (funcall (custom-property (custom-field-custom field) 'accept)
+ field value original)))
+
+(defun custom-field-face (field)
+ "The face used for highlighting FIELD."
+ (let ((custom (custom-field-custom field)))
+ (if (stringp custom)
+ nil
+ (let ((face (funcall (custom-property custom 'face) field)))
+ (if (custom-facep face) face nil)))))
+
+(defun custom-field-update (field)
+ "Update the screen appearance of FIELD to correspond with the field's value."
+ (let ((custom (custom-field-custom field)))
+ (if (stringp custom)
+ nil
+ (funcall (custom-property custom 'update) field))))
;;; Types:
;;
;; The following functions defines type specific actions.
+(defun custom-repeat-eval (custom value)
+ "Non-nil if CUSTOM's VALUE needs to be evaluated."
+ (if (eq value custom-nil)
+ nil
+ (let ((child (custom-data custom))
+ (found nil))
+ (mapcar (lambda (v) (if (custom-eval child v) (setq found t)))
+ value))))
+
+(defun custom-repeat-quote (custom value)
+ "A list of CUSTOM's VALUEs quoted."
+ (let ((child (custom-data custom)))
+ (apply 'append (mapcar (lambda (v) (custom-quote child v))
+ value))))
+
+
+(defun custom-repeat-import (custom value)
+ "Modify CUSTOM's VALUE to match internal expectations."
+ (let ((child (custom-data custom)))
+ (apply 'append (mapcar (lambda (v) (custom-import child v))
+ value))))
+
(defun custom-repeat-accept (field value &optional original)
- "Enter content of editing FIELD."
+ "Store a new value into field FIELD, taking it from VALUE."
(let ((values (copy-sequence (custom-field-value field)))
(all (custom-field-value field))
(start (custom-field-start field))
"Insert field for CUSTOM at nesting LEVEL in customization buffer."
(let* ((field (custom-field-create custom nil))
(add-tag (custom-property custom 'add-tag))
- (del-tag (custom-property custom 'del-tag))
(start (make-marker))
(data (vector field nil start nil)))
(custom-text-insert "\n")
(let ((pos (point)))
+ (custom-text-insert (custom-property custom 'prefix))
(custom-tag-insert add-tag 'custom-repeat-add data)
(set-marker start pos))
(custom-field-move field start (point))
"Insert entry at point in the REPEAT field."
(let* ((inhibit-point-motion-hooks t)
(inhibit-read-only t)
- (before-change-function nil)
- (after-change-function nil)
+ (before-change-functions nil)
+ (after-change-functions nil)
(custom (custom-field-custom repeat))
(add-tag (custom-property custom 'add-tag))
(del-tag (custom-property custom 'del-tag))
(end (make-marker))
(data (vector repeat nil start end))
field)
+ (custom-extent-start-open)
(insert-before-markers "\n")
(backward-char 1)
(set-marker start (point))
(custom-text-insert " ")
(set-marker end (point))
(goto-char start)
+ (custom-text-insert (custom-property custom 'prefix))
(custom-tag-insert add-tag 'custom-repeat-add data)
(custom-text-insert " ")
(custom-tag-insert del-tag 'custom-repeat-delete data)
"Delete list entry."
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t)
- (before-change-function nil)
- (after-change-function nil)
+ (before-change-functions nil)
+ (after-change-functions nil)
(parent (aref data 0))
(field (aref data 1)))
(delete-region (aref data 2) (1+ (aref data 3)))
(cons (nreverse matches) values)))
(defun custom-repeat-extract (custom field)
- "Extract list of childrens values."
+ "Extract list of children's values."
(let ((values (custom-field-value field))
(data (custom-data custom))
result)
(if (eq values custom-nil)
()
(while values
-;; (message "Before values = %S result = %S" values result)
(setq result (append result (custom-field-extract data (car values)))
- values (cdr values))
-;; (message "After values = %S result = %S" values result)
- ))
+ values (cdr values))))
result))
(defun custom-repeat-validate (custom field)
values (cdr values)))
result))
+(defun custom-pair-accept (field value &optional original)
+ "Store a new value into field FIELD, taking it from VALUE."
+ (custom-group-accept field (list (car value) (cdr value)) original))
+
+(defun custom-pair-eval (custom value)
+ "Non-nil if CUSTOM's VALUE needs to be evaluated."
+ (custom-group-eval custom (list (car value) (cdr value))))
+
+(defun custom-pair-import (custom value)
+ "Modify CUSTOM's VALUE to match internal expectations."
+ (let ((result (car (custom-group-import custom
+ (list (car value) (cdr value))))))
+ (custom-assert '(eq (length result) 2))
+ (list (cons (nth 0 result) (nth 1 result)))))
+
+(defun custom-pair-quote (custom value)
+ "Quote CUSTOM's VALUE if necessary."
+ (if (custom-eval custom value)
+ (let ((v (car (custom-group-quote custom
+ &
projects / gnus / blobdiff