-(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)
- "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
- (setq current (car values)
- values (cdr values))
- (if current
- (let* ((custom (custom-field-custom current))
- (match (custom-match custom value)))
- (setq value (cdr match))
- (custom-field-accept current (car match) original))))))
-
-(defun custom-group-insert (custom level)
- "Insert field for CUSTOM at nesting LEVEL in customization buffer."
- (let* ((field (custom-field-create custom nil))
- fields hidden
- (from (point))
- (compact (custom-compact custom))
- (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 (cond (hidden "")
- (compact " ")
- (t "\n"))))))
- (if compact (custom-documentation-insert custom))
- (custom-field-value-set field (nreverse fields))
- (custom-field-move field from (point))
- field))
-
-(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)))
- (custom-text-insert "lars er en nisse")
- (custom-field-move field from (point))
- (custom-documentation-insert custom)
- (custom-field-reset field)
- field))
-
-(defun custom-choice-accept (field value &optional original)
- "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-functions nil)
- (after-change-functions nil)
- from)
- (cond (original
- (setq custom-modified-list (delq field custom-modified-list))
- (custom-field-original-set field value))
- ((equal value (custom-field-original field))
- (setq custom-modified-list (delq field custom-modified-list)))
- (t
- (add-to-list 'custom-modified-list field)))
- (custom-field-untouch (custom-field-value field))
- (delete-region start end)
- (goto-char start)
- (setq from (point))
- (insert-before-markers " ")
- (backward-char 1)
- (custom-category-set (point) (1+ (point)) 'custom-hidden-properties)
- (custom-tag-insert (custom-tag custom) field)
- (custom-text-insert ": ")
- (let ((data (custom-data custom))
- found begin)
- (while (and data (not found))
- (if (not (custom-valid (car data) value))
- (setq data (cdr data))
- (setq found (custom-insert (car data) nil))
- (setq data nil)))
- (if found
- ()
- (setq begin (point)
- found (custom-insert (custom-property custom 'none) nil))
- (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 child's value."
- (let ((value (custom-field-value field)))
- (custom-field-extract (custom-field-custom value) value)))
-
-(defun custom-choice-validate (custom field)
- "Validate child's value."
- (let ((value (custom-field-value field))
- (custom (custom-field-custom field)))
- (if (or (eq value custom-nil)
- (eq (custom-field-custom value) (custom-property custom 'none)))
- (cons (custom-field-start field) "Make a choice")
- (custom-field-validate (custom-field-custom value) value))))
-
-(defun custom-choice-query (field)
- "Choose a child."
- (let* ((custom (custom-field-custom field))
- (old (custom-field-custom (custom-field-value field)))
- (default (custom-prompt old))
- (tag (custom-prompt custom))
- (data (custom-data custom))
- current alist)
- (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"
- (let* ((value (custom-field-value field))
- (custom (custom-field-custom field))
- (valid (custom-valid custom value))
- (directory (custom-property custom 'directory))
- (default (and (not valid)
- (custom-property custom 'default-file)))
- (tag (custom-tag custom))
- (prompt (if default
- (concat tag " (" default "): ")
- (concat tag ": "))))
- (custom-field-accept field
- (if (custom-valid custom value)
- (read-file-name prompt
- (if (file-name-absolute-p value)
- ""
- directory)
- 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 (or (and (facep value) (symbol-name (face-name value)))
- (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))
- (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 validly have the value VALUE."
- (equal (custom-default custom) value))
-
-(defun custom-const-face (field)
- "Face used for a FIELD."
- (custom-default (custom-field-custom field)))
-
-(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."
- (let ((last (length string))
- (padding (custom-padding custom)))
- (while (and (> last 0)
- (eq (aref string (1- last)) padding))
- (setq last (1- last)))
- (substring string 0 last)))
-
-(defun custom-string-write (custom string)
- "Write raw string."
- string)
-
-(defun custom-button-insert (custom level)
- "Insert field for CUSTOM at nesting LEVEL in customization buffer."
- (custom-tag-insert (concat "[" (custom-tag custom) "]")
- (custom-property custom 'query))
- (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))
- (tag (custom-tag custom)))
- (if (null tag)
- ()
- (custom-tag-insert tag field)
- (custom-text-insert ": "))
- (custom-field-insert field)
- (custom-documentation-insert custom)
- field))
-
-(defun custom-default-accept (field value &optional original)
- "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 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-prompt custom) ": ")))
- (custom-field-accept field
- (custom-read custom
- (if (custom-valid custom value)
- (read-string prompt (cons initial 1))
- (read-string prompt))))))
-
-(defun custom-default-match (custom values)
- "Match CUSTOM with VALUES."
- values)
-
-(defun custom-default-extract (custom field)
- "Extract CUSTOM's content in FIELD."
- (list (custom-field-value field)))
-
-(defun custom-default-validate (custom field)
- "Validate FIELD."
- (let ((value (custom-field-value field))
- (start (custom-field-start field)))
- (cond ((eq value custom-nil)
- (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 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 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 SAVE is non-nil, use that for saving changes."
- (switch-to-buffer name)
- (buffer-disable-undo (current-buffer))
- (custom-mode)
- (setq custom-local-type-properties types)
- (if (null custom)
- ()
- (make-local-variable 'custom-data)
- (setq custom-data custom))
- (if (null set)
- ()
- (make-local-variable 'custom-external-set)
- (setq custom-external-set set))
- (if (null get)
- ()
- (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-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-text-insert "\n")
- (custom-insert custom-data 0)
- (goto-char (point-min))))
-
-(defun custom-insert (custom level)
- "Insert custom declaration CUSTOM in current buffer at level LEVEL."
- (if (stringp custom)
- (progn
- (custom-text-insert custom)
- nil)
- (and level (null (custom-property custom 'header))
- (setq level nil))
- (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)))
-
-(defun custom-text-insert (text)
- "Insert TEXT in current buffer."
- (insert text))
-
-(defun custom-tag-insert (tag field &optional data)
- "Insert TAG for FIELD in current buffer."
- (let ((from (point)))
- (insert tag)
- (custom-category-set from (point) 'custom-button-properties)
- (custom-put-text-property from (point) 'custom-tag field)
- (if 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."
- (let ((doc (custom-documentation custom)))
- (if (null doc)
- ()
- (custom-help-insert "\n" doc))))
-
-(defun custom-help-insert (&rest args)
- "Insert ARGS as documentation text."
- (let ((from (point)))
- (apply 'insert args)
- (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)) "'")
- (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 Custom Mode.")
-(if custom-mode-map
- nil
- (setq custom-mode-map (make-sparse-keymap))
- (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
-;; forward-field, C-b backward-field, C-n next-field, C-p
-;; previous-field, ? describe-field.
-
-(defun custom-mode ()
- "Major mode for doing customizations.
-
-\\{custom-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'custom-mode
- mode-name "Custom")
- (use-local-map custom-mode-map)
- (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
- (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)))
-
-(defun custom-forward-field (arg)
- "Move point to the next field or button.
-With optional ARG, move across that many fields."
- (interactive "p")
- (while (> arg 0)
- (let ((next (if (get-text-property (point) 'custom-tag)
- (next-single-property-change (point) 'custom-tag)
- (point))))
- (setq next (or (next-single-property-change next 'custom-tag)
- (next-single-property-change (point-min) 'custom-tag)))
- (if next
- (goto-char next)
- (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 (custom-category-get
- 'custom-documentation-properties 'invisible)))
- (<= (prefix-numeric-value arg) 0))))
- (custom-category-put 'custom-documentation-properties 'invisible hide)
- (custom-category-put 'custom-documentation-properties intangible hide))
- (redraw-display))
-
-(defun custom-enter-value (field data)
- "Enter value for current customization field or push button."
- (interactive (list (get-text-property (point) 'custom-tag)
- (get-text-property (point) 'custom-data)))
- (cond (data
- (funcall field data))
- ((eq field 'custom-enter-value)
- (error "Don't be silly"))
- ((and (symbolp field) (fboundp field))
- (call-interactively field))
- (field
- (custom-field-query field))
- (t
- (message "Nothing to enter here"))))
-
-(defun custom-kill-line ()
- "Kill to end of field or end of line, whichever is first."
- (interactive)
- (let ((field (get-text-property (point) 'custom-field))
- (newline (save-excursion (search-forward "\n")))
- (next (next-single-property-change (point) 'custom-field)))
- (if (and field (> newline next))
- (kill-region (point) next)
- (call-interactively 'kill-line))))
-
-(defun custom-push-button (event)
- "Activate button below mouse pointer."
- (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)))
- (cond (data
- (funcall tag data))
- ((and (symbolp tag) (fboundp tag))
- (call-interactively tag))
- (field
- (call-interactively (lookup-key global-map (this-command-keys))))
- (tag
- (custom-enter-value tag data))
- (t
- (error "Nothing to click on here.")))))
-
-(defun custom-reset-all ()
- "Undo any changes since the last apply in all fields."
- (interactive (and custom-modified-list
- (not (y-or-n-p "Discard all changes? "))
- (error "Reset aborted")))
- (let ((all custom-name-fields)
- current field)
- (while all
- (setq current (car all)
- field (cdr current)
- all (cdr all))
- (custom-field-reset field))))
-
-(defun 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 (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 (if custom-modified-list
- nil
- (error "No changes to apply.")))
- (custom-field-parse custom-field-last)
- (let ((all custom-name-fields)
- field)
- (while all
- (setq field (cdr (car all))
- all (cdr all))
- (let ((error (custom-field-validate (custom-field-custom field) field)))
- (if (null error)
- ()
- (goto-char (car error))
- (error (cdr error))))))
- (let ((all custom-name-fields)
- field)
- (while all
- (setq field (cdr (car all))
- all (cdr all))
- (custom-field-apply field))))
-
-(defun custom-field-apply (field)
- "Apply any changes in FIELD since the last apply."
- (interactive (list (or (get-text-property (point) 'custom-field)
- (get-text-property (point) 'custom-tag))))
- (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.
-
-(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 ((null (custom-data (custom-field-custom field))))
- ((arrayp value)
- (custom-field-untouch value))
- ((listp value)
- (mapcar 'custom-field-untouch value))))))
-
-
-(defun custom-field-insert (field)
- ;; Insert editing FIELD in current buffer.
- (let ((from (point))
- (custom (custom-field-custom field))
- (value (custom-field-value field)))
- (insert (custom-write custom value))
- (insert-char (custom-padding custom)
- (- (custom-width custom) (- (point) from)))
- (custom-field-move field from (point))
- (custom-set-text-properties
- from (point)
- (list 'custom-field field
- 'custom-tag field
- '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)
- (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))
- (custom-put-text-property (custom-field-start field) (custom-field-end field)
- 'face (custom-field-face field))))
-
-(defun custom-field-enter (field)
- ;; Activate FIELD.
- (let* ((start (custom-field-start field))
- (end (custom-field-end field))
- (custom (custom-field-custom field))
- (padding (custom-padding custom))
- (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))))
- (custom-put-text-property start end 'face custom-field-active-face)))
-
-(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.
- (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.
-(make-variable-buffer-local 'custom-field-was)
-
-(defun custom-before-change (begin end)
- ;; Check that we the modification is allowed.
- (if (not (eq major-mode 'custom-mode))
- (message "Aargh! Why is custom-before-change called here?")
- (let ((from (custom-field-property begin))
- (to (custom-field-property end)))
- (cond ((or (null from) (null to))
- (error "You can only modify the fields"))
- ((not (eq from to))
- (error "Changes must be limited to a single field."))
- (t
- (setq custom-field-was from))))))
-
-(defun custom-after-change (begin end length)
- ;; Keep track of field content.
- (if (not (eq major-mode 'custom-mode))
- (message "Aargh! Why is custom-after-change called here?")
- (let ((field custom-field-was))
- (custom-assert '(prog1 field (setq custom-field-was nil)))
- ;; Prevent mixing fields properties.
- (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))
- (add-to-list 'custom-field-changed field))
- ;; We deleted the entire field, reinsert it.
- (custom-assert '(eq begin end))
- (save-excursion
- (goto-char begin)
- (custom-field-value-set field
- (custom-read (custom-field-custom field) ""))
- (custom-field-insert field))))))
-
-(defun custom-field-property (pos)
- ;; The `custom-field' text property valid for POS.
- (or (get-text-property pos 'custom-field)
- (and (not (eq pos (point-min)))
- (get-text-property (1- pos) 'custom-field))))
-
-;;; Generic Utilities:
-;;
-;; Some utility functions that are not really specific to custom.
-
-(defun custom-assert (expr)
- "Assert that EXPR evaluates to non-nil at this point"
- (or (eval expr)
- (error "Assertion failed: %S" expr)))
-
-(defun custom-first-line (string)
- "Return the part of STRING before the first newline."
- (let ((pos 0)
- (len (length string)))
- (while (and (< pos len) (not (eq (aref string pos) ?\n)))
- (setq pos (1+ pos)))
- (if (eq pos len)
- string
- (substring string 0 pos))))
-
-(defun custom-insert-before (list old new)
- "In LIST insert before OLD a NEW element."
- (cond ((null list)
- (list new))
- ((null old)
- (nconc list (list new)))
- ((eq old (car list))
- (cons new list))