;;; 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)))
+(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))
(or (fboundp 'add-to-list)
;; Introduced in Emacs 19.29.
(or (member element (symbol-value list-var))
(set list-var (cons element (symbol-value list-var))))))
-(defvar intangible nil
- "The symbol making text intangible")
+(or (fboundp 'plist-get)
+ ;; Introduced in Emacs 19.29.
+ (defun plist-get (plist prop)
+ "Extract a value from a property list.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
+corresponding to the given PROP, or nil if PROP is not
+one of the properties on the list."
+ (let (result)
+ (while plist
+ (if (eq (car plist) prop)
+ (setq result (car (cdr plist))
+ plist nil)
+ (set plist (cdr (cdr plist)))))
+ result)))
+
+(or (fboundp 'plist-put)
+ ;; Introduced in Emacs 19.29.
+ (defun plist-put (plist prop val)
+ "Change value in PLIST of PROP to VAL.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
+If PROP is already a property on the list, its value is set to VAL,
+otherwise the new PROP VAL pair is added. The new plist is returned;
+use `(setq x (plist-put x prop val))' to be sure to use the new value.
+The PLIST is modified by side effects."
+ (if (null plist)
+ (list prop val)
+ (let ((current plist))
+ (while current
+ (cond ((eq (car current) prop)
+ (setcar (cdr current) val)
+ (setq current nil))
+ ((null (cdr (cdr current)))
+ (setcdr (cdr current) (list prop val))
+ (setq current nil))
+ (t
+ (setq current (cdr (cdr current)))))))
+ plist)))
+
+(or (fboundp 'match-string)
+ ;; Introduced in Emacs 19.29.
+ (defun match-string (num &optional string)
+ "Return string of text matched by last search.
+NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+ (if (match-beginning num)
+ (if string
+ (substring string (match-beginning num) (match-end num))
+ (buffer-substring (match-beginning num) (match-end num))))))
+
+(or (fboundp 'facep)
+ ;; Introduced in Emacs 19.29.
+ (defun facep (x)
+ "Return t if X is a face name or an internal face vector."
+ (and (or (and (fboundp 'internal-facep) (internal-facep x))
+ (and
+ (symbolp x)
+ (assq x (and (boundp 'global-face-data) global-face-data))))
+ t)))
+
+;; 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 (or (null buffer) (bufferp 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)
+ ;; 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.
-If optional ORIGINAL is non-nil, concider VALUE for the original value."
- (funcall (custom-property (custom-field-custom field) 'accept)
- field value 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)))
+
+(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
+ (list (car value) (cdr value))))))
+ (list (list 'cons (nth 0 v) (nth 1 v))))
+ (custom-default-quote custom value)))
+
+(defun custom-pair-extract (custom field)
+ "Extract cons of children's values."
+ (let ((values (custom-field-value field))
+ (data (custom-data custom))
+ result)
+ (custom-assert '(eq (length values) (length data)))
+ (while values
+ (setq result (append result
+ (custom-field-extract (car data) (car values)))
+ data (cdr data)
+ values (cdr values)))
+ (custom-assert '(null data))
+ (list (cons (nth 0 result) (nth 1 result)))))
+
+(defun custom-list-quote (custom value)
+ "Quote CUSTOM's VALUE if necessary."
+ (if (custom-eval custom value)
+ (let ((v (car (custom-group-quote custom value))))
+ (list (cons 'list v)))
+ (custom-default-quote custom value)))
+
(defun custom-list-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)
(custom-assert '(null data))
(list result)))
-(defun custom-list-validate (custom field)
+(defun custom-group-validate (custom field)
"Validate children."
(let ((values (custom-field-value field))
(data (custom-data custom))
values (cdr values)))
result))
+(defun custom-group-eval (custom value)
+ "Non-nil if CUSTOM's VALUE needs to be evaluated."
+ (let ((found nil))
+ (mapcar (lambda (c)
+ (or (stringp c)
+ (let ((match (custom-match c value)))
+ (if (custom-eval c (car match))
+ (setq found t))
+ (setq value (cdr match)))))
+ (custom-data custom))
+ found))
+
+(defun custom-group-quote (custom value)
+ "A list of CUSTOM's VALUE members, quoted."
+ (list (apply 'append
+ (mapcar (lambda (c)
+ (if (stringp c)
+ ()
+ (let ((match (custom-match c value)))
+ (prog1 (custom-quote c (car match))
+ (setq value (cdr match))))))
+ (custom-data custom)))))
+
+(defun custom-group-import (custom value)
+ "Modify CUSTOM's VALUE to match internal expectations."
+ (list (apply 'append
+ (mapcar (lambda (c)
+ (if (stringp c)
+ ()
+ (let ((match (custom-match c value)))
+ (prog1 (custom-import c (car match))
+ (setq value (cdr match))))))
+ (custom-data custom)))))
+
+(defun custom-group-initialize (custom)
+ "Initialize `doc' and `default' entries in CUSTOM."
+ (if (custom-name custom)
+ (custom-default-initialize custom)
+ (mapcar 'custom-initialize (custom-data custom))))
+
+(defun custom-group-apply (field)
+ "Reset `value' in FIELD to `original'."
+ (let ((custom (custom-field-custom field))
+ (values (custom-field-value field)))
+ (if (custom-name custom)
+ (custom-default-apply field)
+ (mapcar 'custom-field-apply values))))
+
+(defun custom-group-reset (field)
+ "Reset `value' in FIELD to `original'."
+ (let ((custom (custom-field-custom field))
+ (values (custom-field-value field)))
+ (if (custom-name custom)
+ (custom-default-reset field)
+ (mapcar 'custom-field-reset values))))
+
+(defun custom-group-factory-reset (field)
+ "Reset `value' in FIELD to `default'."
+ (let ((custom (custom-field-custom field))
+ (values (custom-field-value field)))
+ (if (custom-name custom)
+ (custom-default-factory-reset field)
+ (mapcar 'custom-field-factory-reset values))))
+
+(defun custom-group-find (custom tag)
+ "Find child in CUSTOM with `tag' TAG."
+ (let ((data (custom-data custom))
+ (result nil))
+ (while (not result)
+ (custom-assert 'data)
+ (if (equal (custom-tag (car data)) tag)
+ (setq result (car data))
+ (setq data (cdr data))))))
+
(defun custom-group-accept (field value &optional original)
- "Enter content of editing FIELD with VALUE."
- (let ((values (custom-field-value field))
- current)
+ "Store a new value into field FIELD, taking it from VALUE."
+ (let* ((values (custom-field-value field))
+ (custom (custom-field-custom field))
+ (from (custom-field-start field))
+ (face-tag (custom-face-tag custom))
+ current)
+ (if face-tag
+ (custom-put-text-property from (+ from (length (custom-tag custom)))
+ 'face (funcall face-tag field value)))
(if original
(custom-field-original-set field value))
(while values
(defun custom-group-insert (custom level)
"Insert field for CUSTOM at nesting LEVEL in customization buffer."
(let* ((field (custom-field-create custom nil))
- fields
+ fields hidden
(from (point))
(compact (custom-compact custom))
- (tag (custom-tag custom)))
- (if tag (custom-tag-insert tag field))
+ (tag (custom-tag custom))
+ (face-tag (custom-face-tag custom)))
+ (cond (face-tag (custom-text-insert tag))
+ (tag (custom-tag-insert tag field)))
(or compact (custom-documentation-insert custom))
(or compact (custom-text-insert "\n"))
(let ((data (custom-data custom)))
(while data
(setq fields (cons (custom-insert (car data) (if level (1+ level)))
fields))
+ (setq hidden (or (stringp (car data))
+ (custom-property (car data) 'hidden)))
(setq data (cdr data))
- (if data (custom-text-insert (if compact " " "\n")))))
+ (if data (custom-text-insert (cond (hidden "")
+ (compact " ")
+ (t "\n"))))))
(if compact (custom-documentation-insert custom))
(custom-field-value-set field (nreverse fields))
(custom-field-move field from (point))
(defun custom-choice-insert (custom level)
"Insert field for CUSTOM at nesting LEVEL in customization buffer."
(let* ((field (custom-field-create custom nil))
- (from (point))
- (tag (custom-tag custom)))
+ (from (point)))
(custom-text-insert "lars er en nisse")
(custom-field-move field from (point))
(custom-documentation-insert custom)
field))
(defun custom-choice-accept (field value &optional original)
- "Reset content of editing FIELD."
+ "Store a new value into field FIELD, taking it from VALUE."
(let ((custom (custom-field-custom field))
(start (custom-field-start field))
(end (custom-field-end field))
(inhibit-read-only t)
- (before-change-function nil)
- (after-change-function nil)
+ (before-change-functions nil)
+ (after-change-functions nil)
from)
(cond (original
(setq custom-modified-list (delq field custom-modified-list))
(setq from (point))
(insert-before-markers " ")
(backward-char 1)
- (set-text-properties (point) (1+ (point))
- (list 'invisible t
- intangible t))
+ (custom-category-set (point) (1+ (point)) 'custom-hidden-properties)
(custom-tag-insert (custom-tag custom) field)
(custom-text-insert ": ")
(let ((data (custom-data custom))
()
(setq begin (point)
found (custom-insert (custom-property custom 'none) nil))
- (add-text-properties begin (point)
- (list 'rear-nonsticky t
- 'face custom-field-uninitialized-face)))
+ (custom-add-text-properties
+ begin (point)
+ (list rear-nonsticky t
+ 'face custom-field-uninitialized-face)))
+ (or original
+ (custom-field-original-set found (custom-field-original field)))
(custom-field-accept found value original)
(custom-field-value-set field found)
(custom-field-move field from end))))
(defun custom-choice-extract (custom field)
- "Extract childs value."
+ "Extract child's value."
(let ((value (custom-field-value field)))
(custom-field-extract (custom-field-custom value) value)))
(defun custom-choice-validate (custom field)
- "Validate childs value."
+ "Validate child's value."
(let ((value (custom-field-value field))
(custom (custom-field-custom field)))
(if (or (eq value custom-nil)
(defun custom-choice-query (field)
"Choose a child."
(let* ((custom (custom-field-custom field))
- (default (custom-tag-or-type
- (custom-field-custom (custom-field-value field))))
- (tag (custom-tag-or-type custom))
+ (old (custom-field-custom (custom-field-value field)))
+ (default (custom-prompt old))
+ (tag (custom-prompt custom))
(data (custom-data custom))
current alist)
- (while data
- (setq current (car data)
- data (cdr data))
- (setq alist (cons (cons (custom-tag-or-type current) current) alist)))
- (let ((answer (if (listp last-input-event)
- (x-popup-menu last-input-event
- (list tag (cons "" (reverse alist))))
- (let ((choice (completing-read (concat tag " (default "
- default "): ")
- alist nil t)))
- (if (or (null choice) (string-equal choice ""))
- (setq choice default))
- (cdr (assoc choice alist))))))
- (if answer
- (custom-field-accept field (custom-default answer))))))
+ (if (eq (length data) 2)
+ (custom-field-accept field (custom-default (if (eq (nth 0 data) old)
+ (nth 1 data)
+ (nth 0 data))))
+ (while data
+ (setq current (car data)
+ data (cdr data))
+ (setq alist (cons (cons (custom-prompt current) current) alist)))
+ (let ((answer (cond ((and (fboundp 'button-press-event-p)
+ (fboundp 'popup-menu)
+ (button-press-event-p last-input-event))
+ (cdr (assoc (car (custom-x-really-popup-menu
+ last-input-event tag
+ (reverse alist)))
+ alist)))
+ ((listp last-input-event)
+ (x-popup-menu last-input-event
+ (list tag (cons "" (reverse alist)))))
+ (t
+ (let ((choice (completing-read (concat tag
+ " (default "
+ default
+ "): ")
+ alist nil t)))
+ (if (or (null choice) (string-equal choice ""))
+ (setq choice default))
+ (cdr (assoc choice alist)))))))
+ (if answer
+ (custom-field-accept field (custom-default answer)))))))
(defun custom-file-query (field)
"Prompt for a file name"
default nil value)
(read-file-name prompt directory default)))))
+(defun custom-face-eval (custom value)
+ "Return non-nil if CUSTOM's VALUE needs to be evaluated."
+ (not (symbolp value)))
+
+(defun custom-face-import (custom value)
+ "Modify CUSTOM's VALUE to match internal expectations."
+ (let ((name (symbol-name value)))
+ (list (if (string-match "\
+custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
+ name)
+ (list 'custom-face-lookup
+ (match-string 1 name)
+ (match-string 2 name)
+ (match-string 3 name)
+ (intern (match-string 4 name))
+ (intern (match-string 5 name))
+ (intern (match-string 6 name)))
+ value))))
+
+(defun custom-face-lookup (&optional fg bg stipple bold italic underline)
+ "Lookup or create a face with specified attributes."
+ (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
+ (or fg "default")
+ (or bg "default")
+ (or stipple "default")
+ bold italic underline))))
+ (if (and (custom-facep name)
+ (fboundp 'make-face))
+ ()
+ (copy-face 'default name)
+ (when (and fg
+ (not (string-equal fg "default")))
+ (condition-case ()
+ (set-face-foreground name fg)
+ (error nil)))
+ (when (and bg
+ (not (string-equal bg "default")))
+ (condition-case ()
+ (set-face-background name bg)
+ (error nil)))
+ (when (and stipple
+ (not (string-equal stipple "default"))
+ (not (eq stipple 'custom:asis))
+ (fboundp 'set-face-stipple))
+ (set-face-stipple name stipple))
+ (when (and bold
+ (not (eq bold 'custom:asis)))
+ (condition-case ()
+ (make-face-bold name)
+ (error nil)))
+ (when (and italic
+ (not (eq italic 'custom:asis)))
+ (condition-case ()
+ (make-face-italic name)
+ (error nil)))
+ (when (and underline
+ (not (eq underline 'custom:asis)))
+ (condition-case ()
+ (set-face-underline-p name t)
+ (error nil))))
+ name))
+
+(defun custom-face-hack (field value)
+ "Face that should be used for highlighting FIELD containing VALUE."
+ (let* ((custom (custom-field-custom field))
+ (form (funcall (custom-property custom 'export) custom value))
+ (face (apply (car form) (cdr form))))
+ (if (custom-facep face) face nil)))
+
(defun custom-const-insert (custom level)
"Insert field for CUSTOM at nesting LEVEL in customization buffer."
- (let ((field (custom-field-create custom custom-nil))
- (from (point)))
+ (let* ((field (custom-field-create custom custom-nil))
+ (face (custom-field-face field))
+ (from (point)))
(custom-text-insert (custom-tag custom))
+ (custom-add-text-properties from (point)
+ (list 'face face
+ rear-nonsticky t))
(custom-documentation-insert custom)
(custom-field-move field from (point))
field))
+(defun custom-const-update (field)
+ "Update face of FIELD."
+ (let ((from (custom-field-start field))
+ (custom (custom-field-custom field)))
+ (custom-put-text-property from (+ from (length (custom-tag custom)))
+ 'face (custom-field-face field))))
+
(defun custom-const-valid (custom value)
- "Non-nil if CUSTOM can legally have the value VALUE."
+ "Non-nil if CUSTOM can validly have the value VALUE."
(equal (custom-default custom) value))
-(defun custom-integer-read (custom integer)
- "Read from CUSTOM an INTEGER."
- (string-to-int (save-match-data
- (custom-strip-padding integer (custom-padding custom)))))
+(defun custom-const-face (field)
+ "Face used for a FIELD."
+ (custom-default (custom-field-custom field)))
-(defun custom-integer-write (custom integer)
- "Write CUSTOM INTEGER as string."
- (int-to-string integer))
+(defun custom-sexp-read (custom string)
+ "Read from CUSTOM an STRING."
+ (save-match-data
+ (save-excursion
+ (set-buffer (get-buffer-create " *Custom Scratch*"))
+ (erase-buffer)
+ (insert string)
+ (goto-char (point-min))
+ (prog1 (read (current-buffer))
+ (or (looking-at
+ (concat (regexp-quote (char-to-string
+ (custom-padding custom)))
+ "*\\'"))
+ (error "Junk at end of expression"))))))
+
+(autoload 'pp-to-string "pp")
+
+(defun custom-sexp-write (custom sexp)
+ "Write CUSTOM SEXP as string."
+ (let ((string (prin1-to-string sexp)))
+ (if (<= (length string) (custom-width custom))
+ string
+ (setq string (pp-to-string sexp))
+ (string-match "[ \t\n]*\\'" string)
+ (concat "\n" (substring string 0 (match-beginning 0))))))
(defun custom-string-read (custom string)
"Read string by ignoring trailing padding characters."
(custom-documentation-insert custom)
nil)
+(defun custom-default-export (custom value)
+ ;; Convert CUSTOM's VALUE to external representation.
+ ;; See `custom-import'.
+ (if (custom-eval custom value)
+ (eval (car (custom-quote custom value)))
+ value))
+
+(defun custom-default-quote (custom value)
+ "Quote CUSTOM's VALUE if necessary."
+ (list (if (and (not (custom-eval custom value))
+ (or (and (symbolp value)
+ value
+ (not (eq t value)))
+ (and (listp value)
+ value
+ (not (memq (car value) '(quote function lambda))))))
+ (list 'quote value)
+ value)))
+
+(defun custom-default-initialize (custom)
+ "Initialize `doc' and `default' entries in CUSTOM."
+ (let ((name (custom-name custom)))
+ (if (null name)
+ ()
+ (let ((default (custom-default custom))
+ (doc (custom-documentation custom))
+ (vdoc (documentation-property name 'variable-documentation t)))
+ (if doc
+ (or vdoc (put name 'variable-documentation doc))
+ (if vdoc (custom-property-set custom 'doc vdoc)))
+ (if (eq default custom-nil)
+ (if (boundp name)
+ (custom-property-set custom 'default (symbol-value name)))
+ (or (boundp name)
+ (set name default)))))))
+
(defun custom-default-insert (custom level)
"Insert field for CUSTOM at nesting LEVEL in customization buffer."
(let ((field (custom-field-create custom custom-nil))
field))
(defun custom-default-accept (field value &optional original)
- "Enter into FIELD the value VALUE."
+ "Store a new value into field FIELD, taking it from VALUE."
(if original
(custom-field-original-set field value))
(custom-field-value-set field value)
(custom-field-update field))
+(defun custom-default-apply (field)
+ "Apply any changes in FIELD since the last apply."
+ (let* ((custom (custom-field-custom field))
+ (name (custom-name custom)))
+ (if (null name)
+ (error "This field cannot be applied alone"))
+ (custom-external-set name (custom-name-value name))
+ (custom-field-reset field)))
+
(defun custom-default-reset (field)
- "Reset content of editing FIELD."
+ "Reset content of editing FIELD to `original'."
(custom-field-accept field (custom-field-original field) t))
+(defun custom-default-factory-reset (field)
+ "Reset content of editing FIELD to `default'."
+ (let* ((custom (custom-field-custom field))
+ (default (car (custom-import custom (custom-default custom)))))
+ (or (eq default custom-nil)
+ (custom-field-accept field default nil))))
+
(defun custom-default-query (field)
"Prompt for a FIELD"
(let* ((custom (custom-field-custom field))
(value (custom-field-value field))
(initial (custom-write custom value))
- (prompt (concat (custom-tag-or-type custom) ": ")))
+ (prompt (concat (custom-prompt custom) ": ")))
(custom-field-accept field
(custom-read custom
(if (custom-valid custom value)
(let ((value (custom-field-value field))
(start (custom-field-start field)))
(cond ((eq value custom-nil)
- (cons (custom-field-start field) "Uninitialized field"))
+ (cons start "Uninitialized field"))
+ ((and (consp value) (eq (car value) custom-invalid))
+ (cons start "Unparsable field content"))
((custom-valid custom value)
nil)
(t
- (cons start "Wrong type")))))
+ (cons start "Wrong type of field content")))))
+
+(defun custom-default-face (field)
+ "Face used for a FIELD."
+ (let ((value (custom-field-value field)))
+ (cond ((eq value custom-nil)
+ custom-field-uninitialized-face)
+ ((not (custom-valid (custom-field-custom field) value))
+ custom-field-invalid-face)
+ ((not (equal (custom-field-original field) value))
+ custom-field-modified-face)
+ (t
+ custom-field-face))))
+
+(defun custom-default-update (field)
+ "Update the content of FIELD."
+ (let ((inhibit-point-motion-hooks t)
+ (before-change-functions nil)
+ (after-change-functions nil)
+ (start (custom-field-start field))
+ (end (custom-field-end field))
+ (pos (point)))
+ ;; Keep track of how many modified fields we have.
+ (cond ((equal (custom-field-value field) (custom-field-original field))
+ (setq custom-modified-list (delq field custom-modified-list)))
+ ((memq field custom-modified-list))
+ (t
+ (setq custom-modified-list (cons field custom-modified-list))))
+ ;; Update the field.
+ (goto-char end)
+ (insert-before-markers " ")
+ (delete-region start (1- end))
+ (goto-char start)
+ (custom-field-insert field)
+ (goto-char end)
+ (delete-char 1)
+ (goto-char pos)
+ (and (<= start pos)
+ (<= pos end)
+ (custom-field-enter field))))
;;; Create Buffer:
;;
;; Public functions to create a customization buffer and to insert
;; various forms of text, fields, and buttons in it.
-(defun custom-buffer-create (name &optional custom types set get)
+(defun customize ()
+ "Customize GNU Emacs.
+Create a *Customize* buffer with editable customization information
+about GNU Emacs."
+ (interactive)
+ (custom-buffer-create "*Customize*")
+ (custom-reset-all))
+
+(defun custom-buffer-create (name &optional custom types set get save)
"Create a customization buffer named NAME.
If the optional argument CUSTOM is non-nil, use that as the custom declaration.
If the optional argument TYPES is non-nil, use that as the local types.
If the optional argument SET is non-nil, use that to set external data.
-If the optional argument GET is non-nil, use that to get external data."
+If the optional argument GET is non-nil, use that to get external data.
+If the optional argument SAVE is non-nil, use that for saving changes."
(switch-to-buffer name)
(buffer-disable-undo (current-buffer))
(custom-mode)
()
(make-local-variable 'custom-external)
(setq custom-external get))
+ (if (null save)
+ ()
+ (make-local-variable 'custom-save)
+ (setq custom-save save))
(let ((inhibit-point-motion-hooks t)
- (before-change-function nil)
- (after-change-function nil))
+ (before-change-functions nil)
+ (after-change-functions nil))
(erase-buffer)
(insert "\n")
(goto-char (point-min))
(custom-text-insert "This is a customization buffer.\n")
(custom-help-insert "\n")
(custom-help-button 'custom-forward-field)
+ (custom-help-button 'custom-backward-field)
(custom-help-button 'custom-enter-value)
+ (custom-help-button 'custom-field-factory-reset)
(custom-help-button 'custom-field-reset)
(custom-help-button 'custom-field-apply)
+ (custom-help-button 'custom-save-and-exit)
(custom-help-button 'custom-toggle-documentation)
(custom-help-insert "\nClick mouse-2 on any button to activate it.\n")
- (custom-insert custom 1)
+ (custom-text-insert "\n")
+ (custom-insert custom-data 0)
(goto-char (point-min))))
(defun custom-insert (custom level)
nil)
(and level (null (custom-property custom 'header))
(setq level nil))
- (if level
- (custom-text-insert (concat "\n" (make-string level ?*) " ")))
+ (and level
+ (> level 0)
+ (custom-text-insert (concat "\n" (make-string level ?*) " ")))
(let ((field (funcall (custom-property custom 'insert) custom level)))
(custom-name-enter (custom-name custom) field)
field)))
"Insert TAG for FIELD in current buffer."
(let ((from (point)))
(insert tag)
- (set-text-properties from (point)
- (list 'category custom-button-properties
- 'custom-tag field))
+ (custom-category-set from (point) 'custom-button-properties)
+ (custom-put-text-property from (point) 'custom-tag field)
(if data
- (add-text-properties from (point) (list 'custom-data data)))))
+ (custom-add-text-properties from (point) (list 'custom-data data)))))
(defun custom-documentation-insert (custom &rest ignore)
"Insert documentation from CUSTOM in current buffer."
"Insert ARGS as documentation text."
(let ((from (point)))
(apply 'insert args)
- (set-text-properties from (point)
- (list 'category custom-documentation-properties))))
+ (custom-category-set from (point) 'custom-documentation-properties)))
(defun custom-help-button (command)
"Describe how to execute COMMAND."
(let ((from (point)))
(insert "`" (key-description (where-is-internal command nil t)) "'")
- (set-text-properties from (point)
- (list 'category custom-documentation-properties
- 'face custom-button-face
- 'mouse-face custom-mouse-face
- 'custom-tag command)))
+ (custom-set-text-properties from (point)
+ (list 'face custom-button-face
+ mouse-face custom-mouse-face
+ 'custom-jump t ;Make TAB jump over it.
+ 'custom-tag command
+ 'start-open t
+ 'end-open t))
+ (custom-category-set from (point) 'custom-documentation-properties))
(custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
;;; Mode:
;; The Customization major mode and interactive commands.
(defvar custom-mode-map nil
- "Keymap for Custum Mode.")
+ "Keymap for Custom Mode.")
(if custom-mode-map
nil
(setq custom-mode-map (make-sparse-keymap))
- (define-key custom-mode-map [ mouse-2 ] 'custom-push-button)
+ (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button)
(define-key custom-mode-map "\t" 'custom-forward-field)
+ (define-key custom-mode-map "\M-\t" 'custom-backward-field)
(define-key custom-mode-map "\r" 'custom-enter-value)
(define-key custom-mode-map "\C-k" 'custom-kill-line)
(define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
(define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
+ (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset)
+ (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all)
(define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
(define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
+ (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit)
(define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
(setq major-mode 'custom-mode
mode-name "Custom")
(use-local-map custom-mode-map)
- (make-local-variable 'before-change-function)
- (setq before-change-function 'custom-before-change)
- (make-local-variable 'after-change-function)
- (setq after-change-function 'custom-after-change)
+ (make-local-variable 'before-change-functions)
+ (setq before-change-functions '(custom-before-change))
+ (make-local-variable 'after-change-functions)
+ (setq after-change-functions '(custom-after-change))
(if (not (fboundp 'make-local-hook))
;; Emacs 19.28 and earlier.
- (add-hook 'post-command-hook 'custom-post-command nil)
+ (add-hook 'post-command-hook
+ (lambda ()
+ (if (eq major-mode 'custom-mode)
+ (custom-post-command))))
;; Emacs 19.29.
(make-local-hook 'post-command-hook)
(add-hook 'post-command-hook 'custom-post-command nil t)))
With optional ARG, move across that many fields."
(interactive "p")
(while (> arg 0)
- (setq arg (1- arg))
(let ((next (if (get-text-property (point) 'custom-tag)
(next-single-property-change (point) 'custom-tag)
(point))))
(next-single-property-change (point-min) 'custom-tag)))
(if next
(goto-char next)
- (error "No customization fields in this buffer.")))))
+ (error "No customization fields in this buffer.")))
+ (or (get-text-property (point) 'custom-jump)
+ (setq arg (1- arg))))
+ (while (< arg 0)
+ (let ((previous (if (get-text-property (1- (point)) 'custom-tag)
+ (previous-single-property-change (point) 'custom-tag)
+ (point))))
+ (setq previous
+ (or (previous-single-property-change previous 'custom-tag)
+ (previous-single-property-change (point-max) 'custom-tag)))
+ (if previous
+ (goto-char previous)
+ (error "No customization fields in this buffer.")))
+ (or (get-text-property (1- (point)) 'custom-jump)
+ (setq arg (1+ arg)))))
+
+(defun custom-backward-field (arg)
+ "Move point to the previous field or button.
+With optional ARG, move across that many fields."
+ (interactive "p")
+ (custom-forward-field (- arg)))
(defun custom-toggle-documentation (&optional arg)
"Toggle display of documentation text.
If the optional argument is non-nil, show text iff the argument is positive."
(interactive "P")
(let ((hide (or (and (null arg)
- (null (get custom-documentation-properties 'invisible)))
+ (null (custom-category-get
+ 'custom-documentation-properties 'invisible)))
(<= (prefix-numeric-value arg) 0))))
- (put custom-documentation-properties 'invisible hide)
- (put custom-documentation-properties intangible hide))
+ (custom-category-put 'custom-documentation-properties 'invisible hide)
+ (custom-category-put 'custom-documentation-properties intangible hide))
(redraw-display))
(defun custom-enter-value (field data)
(defun custom-push-button (event)
"Activate button below mouse pointer."
- (interactive "e")
- (set-buffer (window-buffer (posn-window (event-start event))))
- (let* ((pos (posn-point (event-start event)))
+ (interactive "@e")
+ (let* ((pos (event-point event))
(field (get-text-property pos 'custom-field))
(tag (get-text-property pos 'custom-tag))
(data (get-text-property pos 'custom-data)))
(not (y-or-n-p "Discard all changes? "))
(error "Reset aborted")))
(let ((all custom-name-fields)
- current name field)
+ current field)
(while all
(setq current (car all)
- name (car current)
field (cdr current)
all (cdr all))
(custom-field-reset field))))
"Undo any changes in FIELD since the last apply."
(interactive (list (or (get-text-property (point) 'custom-field)
(get-text-property (point) 'custom-tag))))
- (if (not (arrayp field))
- (error "No field to reset here"))
- (let* ((custom (custom-field-custom field))
- (name (custom-name custom)))
- (save-excursion
- (if name
- (custom-field-original-set field (custom-external name)))
- (funcall (custom-property custom 'reset) field))))
+ (if (arrayp field)
+ (let* ((custom (custom-field-custom field))
+ (name (custom-name custom)))
+ (save-excursion
+ (if name
+ (custom-field-original-set
+ field (car (custom-import custom (custom-external name)))))
+ (if (not (custom-valid custom (custom-field-original field)))
+ (error "This field cannot be reset alone")
+ (funcall (custom-property custom 'reset) field)
+ (funcall (custom-property custom 'synchronize) field))))))
+
+(defun custom-factory-reset-all ()
+ "Reset all field to their default values."
+ (interactive (and custom-modified-list
+ (not (y-or-n-p "Discard all changes? "))
+ (error "Reset aborted")))
+ (let ((all custom-name-fields)
+ field)
+ (while all
+ (setq field (cdr (car all))
+ all (cdr all))
+ (custom-field-factory-reset field))))
+
+(defun custom-field-factory-reset (field)
+ "Reset FIELD to its default value."
+ (interactive (list (or (get-text-property (point) 'custom-field)
+ (get-text-property (point) 'custom-tag))))
+ (if (arrayp field)
+ (save-excursion
+ (funcall (custom-property (custom-field-custom field) 'factory-reset)
+ field))))
(defun custom-apply-all ()
"Apply any changes since the last reset in all fields."
- (interactive (or custom-modified-list
- (error "No changes to apply.")))
+ (interactive (if custom-modified-list
+ nil
+ (error "No changes to apply.")))
+ (custom-field-parse custom-field-last)
(let ((all custom-name-fields)
- name field)
+ field)
(while all
(setq field (cdr (car all))
all (cdr all))
(goto-char (car error))
(error (cdr error))))))
(let ((all custom-name-fields)
- current name field)
+ field)
(while all
(setq field (cdr (car all))
all (cdr all))
"Apply any changes in FIELD since the last apply."
(interactive (list (or (get-text-property (point) 'custom-field)
(get-text-property (point) 'custom-tag))))
- (if (not (arrayp field))
- (error "No field to reset here"))
- (let* ((custom (custom-field-custom field))
- (name (custom-name custom))
- (error (custom-field-validate custom field)))
- (cond ((null name)
- (error "This field cannot be applied alone"))
- (error
- (error (cdr error)))
- (t
- (custom-external-set name (car (custom-field-extract custom field)))
- (custom-field-reset field)))))
+ (custom-field-parse custom-field-last)
+ (if (arrayp field)
+ (let* ((custom (custom-field-custom field))
+ (error (custom-field-validate custom field)))
+ (if error
+ (error (cdr error)))
+ (funcall (custom-property custom 'apply) field))))
(defun custom-toggle-hide (&rest ignore)
"Hide or show entry."
(interactive)
(error "This button is not yet implemented"))
+(defun custom-save-and-exit ()
+ "Save and exit customization buffer."
+ (interactive "@")
+ (save-excursion
+ (funcall custom-save))
+ (kill-buffer (current-buffer)))
+
+(defun custom-save ()
+ "Save customization information."
+ (interactive)
+ (custom-apply-all)
+ (let ((new custom-name-fields))
+ (set-buffer (find-file-noselect custom-file))
+ (goto-char (point-min))
+ (save-excursion
+ (let ((old (condition-case nil
+ (read (current-buffer))
+ (end-of-file (append '(setq custom-dummy
+ 'custom-dummy) ())))))
+ (or (eq (car old) 'setq)
+ (error "Invalid customization file: %s" custom-file))
+ (while new
+ (let* ((field (cdr (car new)))
+ (custom (custom-field-custom field))
+ (value (custom-field-original field))
+ (default (car (custom-import custom (custom-default custom))))
+ (name (car (car new))))
+ (setq new (cdr new))
+ (custom-assert '(eq name (custom-name custom)))
+ (if (equal default value)
+ (setcdr old (custom-plist-delq name (cdr old)))
+ (setcdr old (plist-put (cdr old) name
+ (car (custom-quote custom value)))))))
+ (erase-buffer)
+ (insert ";; " custom-file "\
+ --- Automatically generated customization information.
+;;
+;; Feel free to edit by hand, but the entire content should consist of
+;; a single setq. Any other lisp expressions will confuse the
+;; automatic configuration engine.
+
+\(setq ")
+ (setq old (cdr old))
+ (while old
+ (prin1 (car old) (current-buffer))
+ (setq old (cdr old))
+ (insert " ")
+ (pp (car old) (current-buffer))
+ (setq old (cdr old))
+ (if old (insert "\n ")))
+ (insert ")\n")
+ (save-buffer)
+ (kill-buffer (current-buffer))))))
+
+(defun custom-load ()
+ "Save customization information."
+ (interactive (and custom-modified-list
+ (not (equal (list (custom-name-field 'custom-file))
+ custom-modified-list))
+ (not (y-or-n-p "Discard all changes? "))
+ (error "Load aborted")))
+ (load-file (custom-name-value 'custom-file))
+ (custom-reset-all))
+
;;; Field Editing:
;;
;; Various internal functions for implementing the direct editing of
;; fields in the customization buffer.
-(defvar custom-modified-list nil)
-;; List of modified fields.
-(make-variable-buffer-local 'custom-modified-list)
-
(defun custom-field-untouch (field)
;; Remove FIELD and its children from `custom-modified-list'.
(setq custom-modified-list (delq field custom-modified-list))
(if (arrayp field)
(let ((value (custom-field-value field)))
- (cond ((arrayp value)
+ (cond ((null (custom-data (custom-field-custom field))))
+ ((arrayp value)
(custom-field-untouch value))
((listp value)
(mapcar 'custom-field-untouch value))))))
(insert-char (custom-padding custom)
(- (custom-width custom) (- (point) from)))
(custom-field-move field from (point))
- (set-text-properties
+ (custom-set-text-properties
from (point)
(list 'custom-field field
'custom-tag field
'face (custom-field-face field)
- 'front-sticky t))))
-
-(defun custom-field-update (field)
- ;; Update the content of FIELD.
- (let ((inhibit-point-motion-hooks t)
- (before-change-function nil)
- (after-change-function nil)
- (start (custom-field-start field))
- (end (custom-field-end field))
- (pos (point)))
- ;; Keep track of how many modified fields we have.
- (cond ((equal (custom-field-value field) (custom-field-original field))
- (setq custom-modified-list (delq field custom-modified-list)))
- ((memq field custom-modified-list))
- (t
- (setq custom-modified-list (cons field custom-modified-list))))
- ;; Update the field.
- (goto-char end)
- (insert-before-markers " ")
- (delete-region start (1- end))
- (goto-char start)
- (custom-field-insert field)
- (goto-char end)
- (delete-char 1)
- (goto-char pos)
- (and (<= start pos)
- (<= pos end)
- (custom-field-enter field))))
+ 'start-open t
+ 'end-open t))))
(defun custom-field-read (field)
;; Read the screen content of FIELD.
(custom-read (custom-field-custom field)
- (buffer-substring-no-properties (custom-field-start field)
+ (custom-buffer-substring-no-properties (custom-field-start field)
(custom-field-end field))))
-(defun custom-field-face (field)
- ;; Face used for an inactive field FIELD.
- (let ((value (custom-field-value field)))
- (cond ((eq value custom-nil)
- custom-field-uninitialized-face)
- ((not (custom-valid (custom-field-custom field) value))
- custom-field-invalid-face)
- ((not (equal (custom-field-original field) value))
- custom-field-modified-face)
- (t
- custom-field-face))))
+;; Fields are shown in a special `active' face when point is inside
+;; it. You activate the field by moving point inside (entering) it
+;; and deactivate the field by moving point outside (leaving) it.
(defun custom-field-leave (field)
;; Deactivate FIELD.
- (let ((before-change-function nil)
- (after-change-function nil))
- (put-text-property (custom-field-start field) (custom-field-end field)
+ (let ((before-change-functions nil)
+ (after-change-functions nil))
+ (custom-put-text-property (custom-field-start field) (custom-field-end field)
'face (custom-field-face field))))
(defun custom-field-enter (field)
(end (custom-field-end field))
(custom (custom-field-custom field))
(padding (custom-padding custom))
- (allow (custom-allow-padding custom))
- (before-change-function nil)
- (after-change-function nil))
- (or (and (eq this-command 'self-insert-command)
- allow)
+ (before-change-functions nil)
+ (after-change-functions nil))
+ (or (eq this-command 'self-insert-command)
(let ((pos end))
(while (and (< start pos)
(eq (char-after (1- pos)) padding))
(setq pos (1- pos)))
(if (< pos (point))
(goto-char pos))))
- (put-text-property start end 'face custom-field-active-face)))
+ (custom-put-text-property start end 'face custom-field-active-face)))
-(defvar custom-field-last nil)
-;; Last field containing point.
-(make-variable-buffer-local 'custom-field-last)
+(defun custom-field-resize (field)
+ ;; Resize FIELD after change.
+ (let* ((custom (custom-field-custom field))
+ (begin (custom-field-start field))
+ (end (custom-field-end field))
+ (pos (point))
+ (padding (custom-padding custom))
+ (width (custom-width custom))
+ (size (- end begin)))
+ (cond ((< size width)
+ (goto-char end)
+ (if (fboundp 'insert-before-markers-and-inherit)
+ ;; Emacs 19.
+ (insert-before-markers-and-inherit
+ (make-string (- width size) padding))
+ ;; XEmacs: BUG: Doesn't work!
+ (insert-before-markers (make-string (- width size) padding)))
+ (goto-char pos))
+ ((> size width)
+ (let ((start (if (and (< (+ begin width) pos) (<= pos end))
+ pos
+ (+ begin width))))
+ (goto-char end)
+ (while (and (< start (point)) (= (preceding-char) padding))
+ (backward-delete-char 1))
+ (goto-char pos))))))
+
+(defvar custom-field-changed nil)
+;; List of fields changed on the screen but whose VALUE attribute has
+;; not yet been updated to reflect the new screen content.
+(make-variable-buffer-local 'custom-field-changed)
+
+(defun custom-field-parse (field)
+ ;; Parse FIELD content iff changed.
+ (if (memq field custom-field-changed)
+ (progn
+ (setq custom-field-changed (delq field custom-field-changed))
+ (custom-field-value-set field (custom-field-read field))
+ (custom-field-update field))))
(defun custom-post-command ()
;; Keep track of their active field.
- (if (not (eq major-mode 'custom-mode))
- ;; BUG: Should have been local!
- ()
- (let ((field (custom-field-property (point))))
- (if (eq field custom-field-last)
- ()
- (if custom-field-last
- (custom-field-leave custom-field-last))
- (if field
- (custom-field-enter field))
- (setq custom-field-last field)))
- (set-buffer-modified-p custom-modified-list)))
+ (custom-assert '(eq major-mode 'custom-mode))
+ (let ((field (custom-field-property (point))))
+ (if (eq field custom-field-last)
+ (if (memq field custom-field-changed)
+ (custom-field-resize field))
+ (custom-field-parse custom-field-last)
+ (if custom-field-last
+ (custom-field-leave custom-field-last))
+ (if field
+ (custom-field-enter field))
+ (setq custom-field-last field))
+ (set-buffer-modified-p (or custom-modified-list
+ custom-field-changed))))
(defvar custom-field-was nil)
;; The custom data before the change.
(let ((field custom-field-was))
(custom-assert '(prog1 field (setq custom-field-was nil)))
;; Prevent mixing fields properties.
- (put-text-property begin end 'custom-field field)
+ (custom-put-text-property begin end 'custom-field field)
;; Update the field after modification.
(if (eq (custom-field-property begin) field)
(let ((field-end (custom-field-end field)))
(if (> end field-end)
(set-marker field-end end))
- (custom-field-value-set field (custom-field-read field))
- (custom-field-update field))
+ (add-to-list 'custom-field-changed field))
;; We deleted the entire field, reinsert it.
(custom-assert '(eq begin end))
(save-excursion
(substring string (match-end 0))))))
string)
+(defun custom-plist-memq (prop plist)
+ "Return non-nil if PROP is a property of PLIST. Comparison done with EQ."
+ (let (result)
+ (while plist
+ (if (eq (car plist) prop)
+ (setq result plist
+ plist nil)
+ (setq plist (cdr (cdr plist)))))
+ result))
+
+(defun custom-plist-delq (prop plist)
+ "Delete property PROP from property list PLIST."
+ (while (eq (car plist) prop)
+ (setq plist (cdr (cdr plist))))
+ (let ((list plist)
+ (next (cdr (cdr plist))))
+ (while next
+ (if (eq (car next) prop)
+ (progn
+ (setq next (cdr (cdr next)))
+ (setcdr (cdr list) next))
+ (setq list next
+ next (cdr (cdr next))))))
+ plist)
+
+;;; Meta Customization:
+
+(custom-declare '()
+ '((tag . "Meta Customization")
+ (doc . "Customization of the customization support.")
+ (type . group)
+ (data ((type . face-doc))
+ ((tag . "Button Face")
+ (default . bold)
+ (doc . "Face used for tags in customization buffers.")
+ (name . custom-button-face)
+ (synchronize . (lambda (f)
+ (custom-category-put 'custom-button-properties
+ 'face custom-button-face)))
+ (type . face))
+ ((tag . "Mouse Face")
+ (default . highlight)
+ (doc . "\
+Face used when mouse is above a button in customization buffers.")
+ (name . custom-mouse-face)
+ (synchronize . (lambda (f)
+ (custom-category-put 'custom-button-properties
+ mouse-face
+ custom-mouse-face)))
+ (type . face))
+ ((tag . "Field Face")
+ (default . italic)
+ (doc . "Face used for customization fields.")
+ (name . custom-field-face)
+ (type . face))
+ ((tag . "Uninitialized Face")
+ (default . modeline)
+ (doc . "Face used for uninitialized customization fields.")
+ (name . custom-field-uninitialized-face)
+ (type . face))
+ ((tag . "Invalid Face")
+ (default . highlight)
+ (doc . "\
+Face used for customization fields containing invalid data.")
+ (name . custom-field-invalid-face)
+ (type . face))
+ ((tag . "Modified Face")
+ (default . bold-italic)
+ (doc . "Face used for modified customization fields.")
+ (name . custom-field-modified-face)
+ (type . face))
+ ((tag . "Active Face")
+ (default . underline)
+ (doc . "\
+Face used for customization fields while they are being edited.")
+ (name . custom-field-active-face)
+ (type . face)))))
+
+;; custom.el uses two categories.
+
+(custom-category-create 'custom-documentation-properties)
+(custom-category-put 'custom-documentation-properties rear-nonsticky t)
+
+(custom-category-create 'custom-button-properties)
+(custom-category-put 'custom-button-properties 'face custom-button-face)
+(custom-category-put 'custom-button-properties mouse-face custom-mouse-face)
+(custom-category-put 'custom-button-properties rear-nonsticky t)
+
+(custom-category-create 'custom-hidden-properties)
+(custom-category-put 'custom-hidden-properties 'invisible
+ (not (string-match "XEmacs" emacs-version)))
+(custom-category-put 'custom-hidden-properties intangible t)
+
+(if (file-readable-p custom-file)
+ (load-file custom-file))
+
(provide 'custom)
;;; custom.el ends here
projects / gnus / blobdiff