;;; 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.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'.
-;; - Function to generate a XEmacs menu from a CUSTOM.
+;; - 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.
;; - 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.
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."
- (while plist
- (cond ((eq (car plist) prop)
- (setcar (cdr plist) val)
- (setq plist nil))
- ((null (cdr (cdr plist)))
- (setcdr (cdr plist) (list prop val))
- (setq plist nil))
- (t
- (setq plist (cdr (cdr plist))))))))
+ (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 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 global-face-data)))
+ (and
+ (symbolp x)
+ (assq x (and (boundp 'global-face-data) global-face-data))))
t)))
-(if (facep 'underline)
+;; 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.
- (funcall (intern "make-face") 'underline)
+ (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 (face-differs-from-default-p 'underline)
- (funcall 'set-face-underline-p 'underline t)))
-
-(or (fboundp 'set-text-properties)
- ;; Missing in XEmacs 19.12.
- (defun set-text-properties (start end props &optional buffer)
- (if (or (null buffer) (bufferp buffer))
- (if props
- (while props
- (put-text-property
- start end (car props) (nth 1 props) buffer)
- (setq props (nthcdr 2 props)))
- (remove-text-properties start end ())))))
-
-(or (fboundp 'event-closest-point)
+ (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,
(defvar custom-mouse-face nil)
(defvar custom-field-active-face nil))
-(or (and (fboundp 'modify-face) (not (featurep 'face-lock)))
- ;; Introduced in Emacs 19.29. Incompatible definition also introduced
- ;; by face-lock.el version 3.00 and above for Emacs 19.28 and below.
- ;; face-lock does not call modify-face, so we can safely redefine it.
- (defun modify-face (face foreground background stipple
- bold-p italic-p underline-p)
- "Change the display attributes for face FACE.
-FOREGROUND and BACKGROUND should be color strings or nil.
-STIPPLE should be a stipple pattern name or nil.
-BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
-in italic, and underlined, respectively. (Yes if non-nil.)
-If called interactively, prompts for a face and face attributes."
- (interactive
- (let* ((completion-ignore-case t)
- (face (symbol-name (read-face-name "Modify face: ")))
- (colors (mapcar 'list x-colors))
- (stipples (mapcar 'list
- (apply 'nconc
- (mapcar 'directory-files
- x-bitmap-file-path))))
- (foreground (modify-face-read-string
- face (face-foreground (intern face))
- "foreground" colors))
- (background (modify-face-read-string
- face (face-background (intern face))
- "background" colors))
- (stipple (modify-face-read-string
- face (face-stipple (intern face))
- "stipple" stipples))
- (bold-p (y-or-n-p (concat "Set face " face " bold ")))
- (italic-p (y-or-n-p (concat "Set face " face " italic ")))
- (underline-p (y-or-n-p (concat "Set face " face " underline "))))
- (message "Face %s: %s" face
- (mapconcat 'identity
- (delq nil
- (list (and foreground (concat (downcase foreground) " foreground"))
- (and background (concat (downcase background) " background"))
- (and stipple (concat (downcase stipple) " stipple"))
- (and bold-p "bold") (and italic-p "italic")
- (and underline-p "underline"))) ", "))
- (list (intern face) foreground background stipple
- bold-p italic-p underline-p)))
- (condition-case nil (set-face-foreground face foreground) (error nil))
- (condition-case nil (set-face-background face background) (error nil))
- (condition-case nil (set-face-stipple face stipple) (error nil))
- (if (string-match "XEmacs" emacs-version)
- (progn
- (funcall (if bold-p 'make-face-bold 'make-face-unbold) face)
- (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face))
- (funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t)
- (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t))
- (set-face-underline-p face underline-p)
- (and (interactive-p) (redraw-display))))
-
;; We can't easily check for a working intangible.
(defconst intangible (if (and (boundp 'emacs-minor-version)
(or (> emacs-major-version 19)
(> emacs-minor-version 28))))
(setq intangible 'intangible)
(setq intangible 'intangible-if-it-had-been-working))
- "The symbol making text intangible")
+ "The symbol making text intangible.")
(defconst rear-nonsticky (if (string-match "XEmacs" emacs-version)
'end-open
'rear-nonsticky)
- "The symbol making text proeprties non-sticky in the rear end.")
+ "The symbol making text properties non-sticky in the rear end.")
(defconst front-sticky (if (string-match "XEmacs" emacs-version)
'front-closed
"Symbol used for highlighting text under mouse.")
;; Put it in the Help menu, if possible.
-(condition-case nil
- ;; This will not work under XEmacs.
- (global-set-key [ menu-bar help-menu customize ]
- '("Customize..." . customize))
- (error nil))
+(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:
;;
(defun custom-category-set (from to category)
"Make text between FROM and TWO have category CATEGORY."
- (put-text-property from to 'category category)))
+ (custom-put-text-property from to 'category category)))
;;; External Data:
;;
;; 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'.
(defconst custom-type-properties
'((repeat (type . default)
+ ;; See `custom-match'.
(import . custom-repeat-import)
(eval . custom-repeat-eval)
(quote . custom-repeat-quote)
(del-tag . "[DEL]")
(add-tag . "[INS]"))
(pair (type . group)
+ ;; A cons-cell.
(accept . custom-pair-accept)
(eval . custom-pair-eval)
(import . custom-pair-import)
(valid . (lambda (c d) (consp d)))
(extract . custom-pair-extract))
(list (type . group)
+ ;; A lisp list.
(quote . custom-list-quote)
- (valid . (lambda (c d) (listp d)))
+ (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)
(insert . custom-group-insert)
(find . custom-group-find))
(toggle (type . choice)
+ ;; Booleans.
(data ((type . const)
(tag . "On ")
(default . t))
((type . const)
(tag . "Off")
(default . nil))))
+ (triggle (type . choice)
+ ;; On/Off/Default.
+ (data ((type . const)
+ (tag . "On ")
+ (default . t))
+ ((type . const)
+ (tag . "Off")
+ (default . nil))
+ ((type . const)
+ (tag . "Def")
+ (default . custom:asis))))
(choice (type . default)
+ ;; See `custom-match'.
(query . custom-choice-query)
(accept . custom-choice-accept)
(extract . custom-choice-extract)
(default . __uninitialized__)
(type . const)))
(const (type . default)
+ ;; A `const' only matches a single lisp value.
(extract . (lambda (c f) (list (custom-default c))))
(validate . (lambda (c f) nil))
(valid . custom-const-valid)
(update . custom-const-update)
(insert . custom-const-insert))
(face-doc (type . doc)
+ ;; A variable containing a face.
(doc . "\
You can customize the look of Emacs by deciding which faces should be
used when. If you push one of the face buttons below, you will be
(type . string))
"\n"
((tag . "Bold")
- (default . nil)
- (type . toggle))
+ (default . custom:asis)
+ (type . triggle))
" "
((tag . "Italic")
- (default . nil)
- (type . toggle))
+ (default . custom:asis)
+ (type . triggle))
" "
((tag . "Underline")
(hidden . t)
- (default . nil)
- (type . toggle)))
+ (default . custom:asis)
+ (type . triggle)))
(default . (custom-face-lookup "default" "default" "default"
nil nil nil))
(type . list))
((prompt . "Other")
(face . custom-field-value)
+ (default . __uninitialized__)
(type . symbol))))
(file (type . string)
+ ;; A string containing a file or directory name.
(directory . nil)
(default-file . nil)
(query . custom-file-query))
(sexp (type . default)
+ ;; Any lisp expression.
(width . 40)
(default . (__uninitialized__ . "Uninitialized"))
(read . custom-sexp-read)
(write . custom-sexp-write))
(symbol (type . sexp)
+ ;; A lisp symbol.
(width . 40)
(valid . (lambda (c d) (symbolp d))))
(integer (type . sexp)
+ ;; A lisp integer.
(width . 10)
(valid . (lambda (c d) (integerp d))))
(string (type . default)
+ ;; A lisp string.
(width . 40)
(valid . (lambda (c d) (stringp d)))
(read . custom-string-read)
(write . custom-string-write))
(button (type . default)
+ ;; Push me.
(accept . ignore)
(extract . nil)
(validate . ignore)
(insert . custom-button-insert))
(doc (type . default)
+ ;; A documentation only entry with no value.
(header . nil)
(reset . ignore)
(extract . nil)
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__
(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)))
(cdr entry)))
(defun custom-property-set (custom property value)
- "Set CUSTOM PROPERY to VALUE by side effect.
+ "Set CUSTOM PROPERTY to VALUE by side effect.
CUSTOM must have at least one property already."
(let ((entry (assq property custom)))
(if entry
"Extract `tag' from CUSTOM."
(custom-property custom 'tag))
+(defun custom-face-tag (custom)
+ "Extract `face-tag' from CUSTOM."
+ (custom-property custom 'face-tag))
+
(defun custom-prompt (custom)
"Extract `prompt' from CUSTOM.
If none exist, default to `tag' or, failing that, `type'."
(custom-property custom 'padding))
(defun custom-valid (custom value)
- "Non-nil if CUSTOM may legally be set to 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."
+ "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)))
(funcall (custom-property custom 'write) custom value))))
(defun custom-read (custom string)
- "Convert CUSTOM field content STRING into external form."
+ "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)))
;; 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.
(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."
+ "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)))
(let ((custom (custom-field-custom field)))
(if (stringp custom)
nil
- (funcall (custom-property custom 'face) field))))
+ (let ((face (funcall (custom-property custom 'face) field)))
+ (if (custom-facep face) face nil)))))
(defun custom-field-update (field)
- "Update content of FIELD."
+ "Update the screen appearance of FIELD to correspond with the field's value."
(let ((custom (custom-field-custom field)))
(if (stringp custom)
nil
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))
(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))
(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)
result))
(defun custom-pair-accept (field value &optional original)
- "Enter content of editing FIELD with VALUE."
+ "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)
(custom-default-quote custom value)))
(defun custom-pair-extract (custom field)
- "Extract cons of childrens values."
+ "Extract cons of children's values."
(let ((values (custom-field-value field))
(data (custom-data custom))
result)
(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)
(setq data (cdr data))))))
(defun custom-group-accept (field value &optional original)
- "Enter content of editing FIELD with VALUE."
+ "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-property custom 'face-tag))
+ (face-tag (custom-face-tag custom))
current)
(if face-tag
- (put-text-property from (+ from (length (custom-tag custom)))
+ (custom-put-text-property from (+ from (length (custom-tag custom)))
'face (funcall face-tag field value)))
(if original
(custom-field-original-set field value))
(from (point))
(compact (custom-compact custom))
(tag (custom-tag custom))
- (face-tag (custom-property custom 'face-tag)))
+ (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))
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))
()
(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-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)
(setq current (car data)
data (cdr data))
(setq alist (cons (cons (custom-prompt 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))))))
+ (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-face-import (custom value)
"Modify CUSTOM's VALUE to match internal expectations."
- (let ((name (symbol-name value)))
+ (let ((name (or (and (facep value) (symbol-name (face-name value)))
+ (symbol-name value))))
(list (if (string-match "\
custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
name)
(intern (match-string 6 name)))
value))))
-(defun custom-face-lookup (fg bg stipple bold italic underline)
- "Lookup or create a face with specified attributes.
-FG BG STIPPLE BOLD ITALIC UNDERLINE"
+(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 (facep name)
+ (if (and (custom-facep name)
+ (fboundp 'make-face))
()
- (make-face name)
- (modify-face name
- (if (string-equal fg "default") nil fg)
- (if (string-equal bg "default") nil bg)
- (if (string-equal stipple "default") nil stipple)
- bold italic underline))
+ (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)))
- (eval (funcall (custom-property custom 'export) custom 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."
(face (custom-field-face field))
(from (point)))
(custom-text-insert (custom-tag custom))
- (add-text-properties from (point)
+ (custom-add-text-properties from (point)
(list 'face face
rear-nonsticky t))
(custom-documentation-insert custom)
"Update face of FIELD."
(let ((from (custom-field-start field))
(custom (custom-field-custom field)))
- (put-text-property from (+ from (length (custom-tag custom)))
+ (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-const-face (field)
(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))
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)
(cond ((eq value custom-nil)
(cons start "Uninitialized field"))
((and (consp value) (eq (car value) custom-invalid))
- (cons start "Unparseable field content"))
+ (cons start "Unparsable field content"))
((custom-valid custom value)
nil)
(t
(let ((from (point)))
(insert tag)
(custom-category-set from (point) 'custom-button-properties)
- (put-text-property from (point) 'custom-tag field)
+ (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."
"Describe how to execute COMMAND."
(let ((from (point)))
(insert "`" (key-description (where-is-internal command nil t)) "'")
- (set-text-properties from (point)
- (list '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"))
;; 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))
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)
- (setq arg (1+ arg))
(let ((previous (if (get-text-property (1- (point)) 'custom-tag)
(previous-single-property-change (point) 'custom-tag)
(point))))
(previous-single-property-change (point-max) 'custom-tag)))
(if previous
(goto-char previous)
- (error "No customization fields in this buffer.")))))
+ (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.
(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 (let ((face (custom-field-face field)))
- (if (facep face) face nil))
- front-sticky t))))
+ 'face (custom-field-face 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))))
+;; 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-functions nil)
(after-change-functions nil))
- (put-text-property (custom-field-start field) (custom-field-end field)
+ (custom-put-text-property (custom-field-start field) (custom-field-end field)
'face (custom-field-face field))))
(defun custom-field-enter (field)
(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)))
(defun custom-field-resize (field)
;; Resize FIELD after change.
(size (- end begin)))
(cond ((< size width)
(goto-char end)
- (condition-case nil
+ (if (fboundp 'insert-before-markers-and-inherit)
+ ;; Emacs 19.
(insert-before-markers-and-inherit
(make-string (- width size) padding))
- (error (insert-before-markers
- (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))
(goto-char pos))))))
(defvar custom-field-changed nil)
-;; List of fields changed on the screen.
+;; 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)
(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)))