;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 1.84
+;; Version: 1.90
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
;;; Commentary:
;;
+;; This file implements the code to create and edit customize buffers.
+;;
;; See `custom.el'.
;;; Code:
(require 'cus-face)
(require 'wid-edit)
(require 'easymenu)
+(eval-when-compile (require 'cl))
+
+(condition-case nil
+ (require 'cus-load)
+ (error nil))
(defun custom-face-display-set (face spec &optional frame)
(face-spec-set face spec frame))
(if v
(format "Customize variable (default %s): " v)
"Customize variable: ")
- obarray 'boundp t))
+ obarray (lambda (symbol)
+ (and (boundp symbol)
+ (or (get symbol 'custom-type)
+ (user-variable-p symbol))))))
(list (if (equal val "")
v (intern val)))))
+(defun custom-menu-filter (menu widget)
+ "Convert MENU to the form used by `widget-choose'.
+MENU should be in the same format as `custom-variable-menu'.
+WIDGET is the widget to apply the filter entries of MENU on."
+ (let ((result nil)
+ current name action filter)
+ (while menu
+ (setq current (car menu)
+ name (nth 0 current)
+ action (nth 1 current)
+ filter (nth 2 current)
+ menu (cdr menu))
+ (if (or (null filter) (funcall filter widget))
+ (push (cons name action) result)
+ (push name result)))
+ (nreverse result)))
+
;;; Unlispify.
(defvar custom-prefix-list nil
;;; The Customize Commands
+(defun custom-prompt-variable (prompt-var prompt-val)
+ "Prompt for a variable and a value and return them as a list.
+PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the
+prompt for the value. The %s escape in PROMPT-VAL is replaced with
+the name of the variable.
+
+If the variable has a `variable-interactive' property, that is used as if
+it were the arg to `interactive' (which see) to interactively read the value.
+
+If the variable has a `custom-type' property, it must be a widget and the
+`:prompt-value' property of that widget will be used for reading the value."
+ (let* ((var (read-variable prompt-var))
+ (minibuffer-help-form '(describe-variable var)))
+ (list var
+ (let ((prop (get var 'variable-interactive))
+ (type (get var 'custom-type))
+ (prompt (format prompt-val var)))
+ (unless (listp type)
+ (setq type (list type)))
+ (cond (prop
+ ;; Use VAR's `variable-interactive' property
+ ;; as an interactive spec for prompting.
+ (call-interactively (list 'lambda '(arg)
+ (list 'interactive prop)
+ 'arg)))
+ (type
+ (widget-prompt-value type
+ prompt
+ (if (boundp var)
+ (symbol-value var))
+ (not (boundp var))))
+ (t
+ (eval-minibuffer prompt)))))))
+
+;;;###autoload
+(defun custom-set-value (var val)
+ "Set VARIABLE to VALUE. VALUE is a Lisp object.
+
+If VARIABLE has a `variable-interactive' property, that is used as if
+it were the arg to `interactive' (which see) to interactively read the value.
+
+If VARIABLE has a `custom-type' property, it must be a widget and the
+`:prompt-value' property of that widget will be used for reading the value."
+ (interactive (custom-prompt-variable "Set variable: "
+ "Set %s to value: "))
+
+ (set var val))
+
+;;;###autoload
+(defun custom-set-variable (var val)
+ "Set the default for VARIABLE to VALUE. VALUE is a Lisp object.
+
+If VARIABLE has a `custom-set' property, that is used for setting
+VARIABLE, otherwise `set-default' is used.
+
+The `customized-value' property of the VARIABLE will be set to a list
+with a quoted VALUE as its sole list member.
+
+If VARIABLE has a `variable-interactive' property, that is used as if
+it were the arg to `interactive' (which see) to interactively read the value.
+
+If VARIABLE has a `custom-type' property, it must be a widget and the
+`:prompt-value' property of that widget will be used for reading the value. "
+ (interactive (custom-prompt-variable "Set variable: "
+ "Set customized value for %s to: "))
+ (funcall (or (get var 'custom-set) 'set-default) var val)
+ (put var 'customized-value (list (custom-quote val))))
+
;;;###autoload
(defun customize (symbol)
"Customize SYMBOL, which must be a customization group."
(setq symbol (intern symbol))))
(custom-buffer-create (list (list symbol 'custom-group))))
+;;;###autoload
+(defun customize-other-window (symbol)
+ "Customize SYMBOL, which must be a customization group."
+ (interactive (list (completing-read "Customize group: (default emacs) "
+ obarray
+ (lambda (symbol)
+ (get symbol 'custom-group))
+ t)))
+
+ (when (stringp symbol)
+ (if (string-equal "" symbol)
+ (setq symbol 'emacs)
+ (setq symbol (intern symbol))))
+ (custom-buffer-create-other-window (list (list symbol 'custom-group))))
+
;;;###autoload
(defun customize-variable (symbol)
"Customize SYMBOL, which must be a variable."
;;;###autoload
(defun customize-customized ()
- "Customize all already customized user options."
+ "Customize all user options set since the last save in this session."
+ (interactive)
+ (let ((found nil))
+ (mapatoms (lambda (symbol)
+ (and (get symbol 'customized-face)
+ (custom-facep symbol)
+ (setq found (cons (list symbol 'custom-face) found)))
+ (and (get symbol 'customized-value)
+ (boundp symbol)
+ (setq found
+ (cons (list symbol 'custom-variable) found)))))
+ (if found
+ (custom-buffer-create found)
+ (error "No customized user options"))))
+
+;;;###autoload
+(defun customize-saved ()
+ "Customize all already saved user options."
(interactive)
(let ((found nil))
(mapatoms (lambda (symbol)
(cons (list symbol 'custom-variable) found)))))
(if found
(custom-buffer-create found)
- (error "No customized user options"))))
+ (error "No saved user options"))))
;;;###autoload
(defun customize-apropos (regexp &optional all)
(custom-buffer-create found)
(error "No matches"))))
+;;; Buffer.
+
;;;###autoload
(defun custom-buffer-create (options)
"Create a buffer containing OPTIONS.
(switch-to-buffer (get-buffer-create "*Customization*"))
(custom-buffer-create-internal options))
+;;;###autoload
(defun custom-buffer-create-other-window (options)
"Create a buffer containing OPTIONS.
OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
(message "Creating customization setup...")
(widget-setup)
(goto-char (point-min))
+ (forward-line 3) ;Kludge: bob is writable in XEmacs.
(message "Creating customization buffer...done"))
;;; Modification of Basic Widgets.
"Show and manipulate state for a customization option."
:format "%v"
:action 'widget-choice-item-action
+ :notify 'ignore
:value-get 'ignore
:value-create 'custom-magic-value-create
:value-delete 'widget-children-value-delete)
(defun custom-level-action (widget &optional event)
"Toggle visibility for parent to WIDGET."
- (let* ((parent (widget-get widget :parent))
- (state (widget-get parent :custom-state)))
- (cond ((memq state '(invalid modified))
- (error "There are unset changes"))
- ((eq state 'hidden)
- (widget-put parent :custom-state 'unknown))
- (t
- (widget-put parent :custom-state 'hidden)))
- (custom-redraw parent)))
+ (custom-toggle-hide (widget-get widget :parent)))
;;; The `custom' Widget.
(defun custom-redraw (widget)
"Redraw WIDGET with current settings."
- (let ((pos (point))
+ (let ((line (count-lines (point-min) (point)))
+ (column (current-column))
+ (pos (point))
(from (marker-position (widget-get widget :from)))
(to (marker-position (widget-get widget :to))))
(save-excursion
(widget-value-set widget (widget-value widget))
(custom-redraw-magic widget))
(when (and (>= pos from) (<= pos to))
- (goto-char pos))))
+ (condition-case nil
+ (progn
+ (goto-line line)
+ (move-to-column column))
+ (error nil)))))
(defun custom-redraw-magic (widget)
"Redraw WIDGET state with current settings."
"Load all dependencies for WIDGET."
(custom-load-symbol (widget-value widget)))
+(defun custom-toggle-hide (widget)
+ "Toggle visibility of WIDGET."
+ (let ((state (widget-get widget :custom-state)))
+ (cond ((memq state '(invalid modified))
+ (error "There are unset changes"))
+ ((eq state 'hidden)
+ (widget-put widget :custom-state 'unknown))
+ (t
+ (widget-put widget :custom-state 'hidden)))
+ (custom-redraw widget)))
+
;;; The `custom-variable' Widget.
(defface custom-variable-sample-face '((t (:underline t)))
(tag (widget-get widget :tag))
(type (custom-variable-type symbol))
(conv (widget-convert type))
+ (get (or (get symbol 'custom-get) 'default-value))
+ (set (or (get symbol 'custom-set) 'set-default))
(value (if (default-boundp symbol)
- (default-value symbol)
+ (funcall get symbol)
(widget-get conv :value))))
;; If the widget is new, the child determine whether it is hidden.
(cond (state)
((get symbol 'factory-value)
(car (get symbol 'factory-value)))
((default-boundp symbol)
- (custom-quote (default-value symbol)))
+ (custom-quote (funcall get symbol)))
(t
(custom-quote (widget-get conv :value))))))
(push (widget-create-child-and-convert
(defun custom-variable-state-set (widget)
"Set the state of WIDGET."
(let* ((symbol (widget-value widget))
+ (get (or (get symbol 'custom-get) 'default-value))
(value (if (default-boundp symbol)
- (default-value symbol)
+ (funcall get symbol)
(widget-get widget :value)))
tmp
(state (cond ((setq tmp (get symbol 'customized-value))
(widget-put widget :custom-state state)))
(defvar custom-variable-menu
- '(("Edit" . custom-variable-edit)
- ("Edit Lisp" . custom-variable-edit-lisp)
- ("Set" . custom-variable-set)
- ("Save" . custom-variable-save)
- ("Reset to Current" . custom-redraw)
- ("Reset to Saved" . custom-variable-reset-saved)
- ("Reset to Factory Settings" . custom-variable-reset-factory))
+ '(("Hide" custom-toggle-hide
+ (lambda (widget)
+ (not (memq (widget-get widget :custom-state) '(modified invalid)))))
+ ("Edit" custom-variable-edit
+ (lambda (widget)
+ (not (eq (widget-get widget :custom-form) 'edit))))
+ ("Edit Lisp" custom-variable-edit-lisp
+ (lambda (widget)
+ (not (eq (widget-get widget :custom-form) 'lisp))))
+ ("Set" custom-variable-set
+ (lambda (widget)
+ (eq (widget-get widget :custom-state) 'modified)))
+ ("Save" custom-variable-save
+ (lambda (widget)
+ (memq (widget-get widget :custom-state) '(modified set changed rogue))))
+ ("Reset to Current" custom-redraw
+ (lambda (widget)
+ (and (default-boundp (widget-value widget))
+ (memq (widget-get widget :custom-state) '(modified)))))
+ ("Reset to Saved" custom-variable-reset-saved
+ (lambda (widget)
+ (and (get (widget-value widget) 'saved-value)
+ (memq (widget-get widget :custom-state)
+ '(modified set changed rogue)))))
+ ("Reset to Factory Settings" custom-variable-reset-factory
+ (lambda (widget)
+ (and (get (widget-value widget) 'factory-value)
+ (memq (widget-get widget :custom-state)
+ '(modified set changed saved rogue))))))
"Alist of actions for the `custom-variable' widget.
-The key is a string containing the name of the action, the value is a
-lisp function taking the widget as an element which will be called
-when the action is chosen.")
+Each entry has the form (NAME ACTION FILTER) where NAME is the name of
+the menu entry, ACTION is the function to call on the widget when the
+menu is selected, and FILTER is a predicate which takes a `custom-variable'
+widget as an argument, and returns non-nil if ACTION is valid on that
+widget. If FILTER is nil, ACTION is always valid.")
(defun custom-variable-action (widget &optional event)
"Show the menu for `custom-variable' WIDGET.
Optional EVENT is the location for the menu."
(if (eq (widget-get widget :custom-state) 'hidden)
- (progn
- (widget-put widget :custom-state 'unknown)
- (custom-redraw widget))
+ (custom-toggle-hide widget)
(let* ((completion-ignore-case t)
(answer (widget-choose (custom-unlispify-tag-name
(widget-get widget :value))
- custom-variable-menu
+ (custom-menu-filter custom-variable-menu
+ widget)
event)))
(if answer
(funcall answer widget)))))
(defun custom-variable-set (widget)
"Set the current value for the variable being edited by WIDGET."
- (let ((form (widget-get widget :custom-form))
- (state (widget-get widget :custom-state))
- (child (car (widget-get widget :children)))
- (symbol (widget-value widget))
- val)
+ (let* ((form (widget-get widget :custom-form))
+ (state (widget-get widget :custom-state))
+ (child (car (widget-get widget :children)))
+ (symbol (widget-value widget))
+ (set (or (get symbol 'custom-set) 'set-default))
+ val)
(cond ((eq state 'hidden)
(error "Cannot set hidden variable."))
((setq val (widget-apply child :validate))
(goto-char (widget-get val :from))
(error "%s" (widget-get val :error)))
((eq form 'lisp)
- (set-default symbol (eval (setq val (widget-value child))))
+ (funcall set symbol (eval (setq val (widget-value child))))
(put symbol 'customized-value (list val)))
(t
- (set-default symbol (setq val (widget-value child)))
+ (funcall set symbol (setq val (widget-value child)))
(put symbol 'customized-value (list (custom-quote val)))))
(custom-variable-state-set widget)
(custom-redraw-magic widget)))
(defun custom-variable-save (widget)
"Set the default value for the variable being edited by WIDGET."
- (let ((form (widget-get widget :custom-form))
- (state (widget-get widget :custom-state))
- (child (car (widget-get widget :children)))
- (symbol (widget-value widget))
- val)
+ (let* ((form (widget-get widget :custom-form))
+ (state (widget-get widget :custom-state))
+ (child (car (widget-get widget :children)))
+ (symbol (widget-value widget))
+ (set (or (get symbol 'custom-set) 'set-default))
+ val)
(cond ((eq state 'hidden)
(error "Cannot set hidden variable."))
((setq val (widget-apply child :validate))
(error "%s" (widget-get val :error)))
((eq form 'lisp)
(put symbol 'saved-value (list (widget-value child)))
- (set-default symbol (eval (widget-value child))))
+ (funcall set symbol (eval (widget-value child))))
(t
(put symbol
'saved-value (list (custom-quote (widget-value
child))))
- (set-default symbol (widget-value child))))
+ (funcall set symbol (widget-value child))))
(put symbol 'customized-value nil)
(custom-save-all)
(custom-variable-state-set widget)
(defun custom-variable-reset-saved (widget)
"Restore the saved value for the variable being edited by WIDGET."
- (let ((symbol (widget-value widget)))
+ (let* ((symbol (widget-value widget))
+ (set (or (get symbol 'custom-set) 'set-default)))
(if (get symbol 'saved-value)
(condition-case nil
- (set-default symbol (eval (car (get symbol 'saved-value))))
+ (funcall set symbol (eval (car (get symbol 'saved-value))))
(error nil))
(error "No saved value for %s" symbol))
(put symbol 'customized-value nil)
(defun custom-variable-reset-factory (widget)
"Restore the factory setting for the variable being edited by WIDGET."
- (let ((symbol (widget-value widget)))
+ (let* ((symbol (widget-value widget))
+ (set (or (get symbol 'custom-set) 'set-default)))
(if (get symbol 'factory-value)
- (set-default symbol (eval (car (get symbol 'factory-value))))
+ (funcall set symbol (eval (car (get symbol 'factory-value))))
(error "No factory default for %S" symbol))
(put symbol 'customized-value nil)
(when (get symbol 'saved-value)
(defun custom-display-unselected-match (widget value)
"Non-nil if VALUE is an unselected display specification."
- (and (listp value)
- (eq (length value) 2)
- (not (custom-display-match-frame value (selected-frame)))))
+ (not (custom-display-match-frame value (selected-frame))))
(define-widget 'custom-face-selected 'group
"Edit the attributes of the selected display in a face specification."
(message "Creating face editor...done")))
(defvar custom-face-menu
- '(("Edit Selected" . custom-face-edit-selected)
- ("Edit All" . custom-face-edit-all)
- ("Edit Lisp" . custom-face-edit-lisp)
- ("Set" . custom-face-set)
- ("Save" . custom-face-save)
- ("Reset to Saved" . custom-face-reset-saved)
- ("Reset to Factory Setting" . custom-face-reset-factory))
+ '(("Hide" custom-toggle-hide
+ (lambda (widget)
+ (not (memq (widget-get widget :custom-state) '(modified invalid)))))
+ ("Edit Selected" custom-face-edit-selected
+ (lambda (widget)
+ (not (eq (widget-get widget :custom-form) 'selected))))
+ ("Edit All" custom-face-edit-all
+ (lambda (widget)
+ (not (eq (widget-get widget :custom-form) 'all))))
+ ("Edit Lisp" custom-face-edit-lisp
+ (lambda (widget)
+ (not (eq (widget-get widget :custom-form) 'lisp))))
+ ("Set" custom-face-set)
+ ("Save" custom-face-save)
+ ("Reset to Saved" custom-face-reset-saved
+ (lambda (widget)
+ (get (widget-value widget) 'saved-face)))
+ ("Reset to Factory Setting" custom-face-reset-factory
+ (lambda (widget)
+ (get (widget-value widget) 'factory-face))))
"Alist of actions for the `custom-face' widget.
-The key is a string containing the name of the action, the value is a
-lisp function taking the widget as an element which will be called
-when the action is chosen.")
+Each entry has the form (NAME ACTION FILTER) where NAME is the name of
+the menu entry, ACTION is the function to call on the widget when the
+menu is selected, and FILTER is a predicate which takes a `custom-face'
+widget as an argument, and returns non-nil if ACTION is valid on that
+widget. If FILTER is nil, ACTION is always valid.")
(defun custom-face-edit-selected (widget)
"Edit selected attributes of the value of WIDGET."
"Show the menu for `custom-face' WIDGET.
Optional EVENT is the location for the menu."
(if (eq (widget-get widget :custom-state) 'hidden)
- (progn
- (widget-put widget :custom-state 'unknown)
- (custom-redraw widget))
+ (custom-toggle-hide widget)
(let* ((completion-ignore-case t)
(symbol (widget-get widget :value))
(answer (widget-choose (custom-unlispify-tag-name symbol)
- custom-face-menu event)))
+ (custom-menu-filter custom-face-menu
+ widget)
+ event)))
(if answer
(funcall answer widget)))))
(message "Creating group... done")))))
(defvar custom-group-menu
- '(("Set" . custom-group-set)
- ("Save" . custom-group-save)
- ("Reset to Current" . custom-group-reset-current)
- ("Reset to Saved" . custom-group-reset-saved)
- ("Reset to Factory" . custom-group-reset-factory))
+ '(("Hide" custom-toggle-hide
+ (lambda (widget)
+ (not (memq (widget-get widget :custom-state) '(modified invalid)))))
+ ("Set" custom-group-set
+ (lambda (widget)
+ (eq (widget-get widget :custom-state) 'modified)))
+ ("Save" custom-group-save
+ (lambda (widget)
+ (memq (widget-get widget :custom-state) '(modified set))))
+ ("Reset to Current" custom-group-reset-current
+ (lambda (widget)
+ (and (default-boundp (widget-value widget))
+ (memq (widget-get widget :custom-state) '(modified)))))
+ ("Reset to Saved" custom-group-reset-saved
+ (lambda (widget)
+ (and (get (widget-value widget) 'saved-value)
+ (memq (widget-get widget :custom-state) '(modified set)))))
+ ("Reset to Factory" custom-group-reset-factory
+ (lambda (widget)
+ (and (get (widget-value widget) 'factory-value)
+ (memq (widget-get widget :custom-state) '(modified set saved))))))
"Alist of actions for the `custom-group' widget.
-The key is a string containing the name of the action, the value is a
-lisp function taking the widget as an element which will be called
-when the action is chosen.")
+Each entry has the form (NAME ACTION FILTER) where NAME is the name of
+the menu entry, ACTION is the function to call on the widget when the
+menu is selected, and FILTER is a predicate which takes a `custom-group'
+widget as an argument, and returns non-nil if ACTION is valid on that
+widget. If FILTER is nil, ACTION is always valid.")
(defun custom-group-action (widget &optional event)
"Show the menu for `custom-group' WIDGET.
Optional EVENT is the location for the menu."
(if (eq (widget-get widget :custom-state) 'hidden)
- (progn
- (widget-put widget :custom-state 'unknown)
- (custom-redraw widget))
+ (custom-toggle-hide widget)
(let* ((completion-ignore-case t)
(answer (widget-choose (custom-unlispify-tag-name
(widget-get widget :value))
- custom-group-menu
+ (custom-menu-filter custom-group-menu
+ widget)
event)))
(if answer
(funcall answer widget)))))
(princ "\n"))
(princ "(custom-set-variables")
(mapatoms (lambda (symbol)
- (let ((value (get symbol 'saved-value)))
+ (let ((value (get symbol 'saved-value))
+ (requests (get symbol 'custom-requests))
+ (now (not (or (get symbol 'factory-value)
+ (and (not (boundp symbol))
+ (not (get symbol 'force-value)))))))
(when value
(princ "\n '(")
(princ symbol)
(princ " ")
(prin1 (car value))
- (if (or (get symbol 'factory-value)
- (and (not (boundp symbol))
- (not (get symbol 'force-value))))
- (princ ")")
- (princ " t)"))))))
+ (cond (requests
+ (if now
+ (princ " t ")
+ (princ " nil "))
+ (prin1 requests)
+ (princ ")"))
+ (now
+ (princ " t)"))
+ (t
+ (princ ")")))))))
(princ ")")
(unless (looking-at "\n")
(princ "\n")))))
(unless (looking-at "\n")
(princ "\n")))))
+;;;###autoload
+(defun custom-save-customized ()
+ "Save all user options which have been set in this session."
+ (interactive)
+ (mapatoms (lambda (symbol)
+ (let ((face (get symbol 'customized-face))
+ (value (get symbol 'customized-value)))
+ (when face
+ (put symbol 'saved-face face)
+ (put symbol 'customized-face nil))
+ (when value
+ (put symbol 'saved-value value)
+ (put symbol 'customized-value nil)))))
+ ;; We really should update all custom buffers here.
+ (custom-save-all))
+
;;;###autoload
(defun custom-save-all ()
"Save all customizations in `custom-file'."
(easy-menu-define custom-mode-customize-menu
custom-mode-map
- "Menu used in customization buffers."
+ "Menu used to customize customization buffers."
(customize-menu-create 'customize))
(easy-menu-define custom-mode-menu
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 1.84
+;; Version: 1.90
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
(require 'widget)
-(define-widget-keywords :prefix :tag :load :link :options :type :group)
+(define-widget-keywords :initialize :set :get :require :prefix :tag
+ :load :link :options :type :group)
+
(defvar custom-define-hook nil
;; Customize information for this option is in `cus-edit.el'.
;;; The `defcustom' Macro.
-(defun custom-declare-variable (symbol value doc &rest args)
- "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
- ;; Bind this variable unless it already is bound.
+(defun custom-initialize-default (symbol value)
+ "Initialize SYMBOL with VALUE.
+This will do nothing if symbol already has a default binding.
+Otherwise, if symbol has a `saved-value' property, it will evaluate
+the car of that and used as the default binding for symbol.
+Otherwise, VALUE will be evaluated and used as the default binding for
+symbol."
(unless (default-boundp symbol)
;; Use the saved value if it exists, otherwise the factory setting.
(set-default symbol (if (get symbol 'saved-value)
(eval (car (get symbol 'saved-value)))
- (eval value))))
+ (eval value)))))
+
+(defun custom-initialize-set (symbol value)
+ "Initialize SYMBOL with VALUE.
+Like `custom-initialize-default', but use the function specified by
+`:set' to initialize SYMBOL."
+ (unless (default-boundp symbol)
+ (funcall (or (get symbol 'custom-set) 'set-default)
+ symbol
+ (if (get symbol 'saved-value)
+ (eval (car (get symbol 'saved-value)))
+ (eval value)))))
+
+(defun custom-initialize-reset (symbol value)
+ "Initialize SYMBOL with VALUE.
+Like `custom-initialize-set', but use the function specified by
+`:get' to reinitialize SYMBOL if it is already bound."
+ (funcall (or (get symbol 'custom-set) 'set-default)
+ symbol
+ (cond ((default-boundp symbol)
+ (funcall (or (get symbol 'custom-get) 'default-value)
+ symbol))
+ ((get symbol 'saved-value)
+ (eval (car (get symbol 'saved-value))))
+ (t
+ (eval value)))))
+
+(defun custom-initialize-changed (symbol value)
+ "Initialize SYMBOL with VALUE.
+Like `custom-initialize-reset', but only use the `:set' function if the
+not using the factory setting. Otherwise, use the `set-default'."
+ (cond ((default-boundp symbol)
+ (funcall (or (get symbol 'custom-set) 'set-default)
+ symbol
+ (funcall (or (get symbol 'custom-get) 'default-value)
+ symbol)))
+ ((get symbol 'saved-value)
+ (funcall (or (get symbol 'custom-set) 'set-default)
+ symbol
+ (eval (car (get symbol 'saved-value)))))
+ (t
+ (set-default symbol (eval value)))))
+
+(defun custom-declare-variable (symbol value doc &rest args)
+ "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
;; Remember the factory setting.
(put symbol 'factory-value (list value))
;; Maybe this option was rogue in an earlier version. It no longer is.
(put symbol 'force-value nil))
(when doc
(put symbol 'variable-documentation doc))
- (while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (unless (symbolp arg)
- (error "Junk in args %S" args))
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" keyword))
+ (let ((initialize 'custom-initialize-set)
+ (requests nil))
+ (while args
+ (let ((arg (car args)))
(setq args (cdr args))
- (cond ((eq keyword :type)
- (put symbol 'custom-type value))
- ((eq keyword :options)
- (if (get symbol 'custom-options)
- ;; Slow safe code to avoid duplicates.
- (mapcar (lambda (option)
- (custom-add-option symbol option))
- value)
- ;; Fast code for the common case.
- (put symbol 'custom-options (copy-sequence value))))
- (t
- (custom-handle-keyword symbol keyword value
- 'custom-variable))))))
+ (unless (symbolp arg)
+ (error "Junk in args %S" args))
+ (let ((keyword arg)
+ (value (car args)))
+ (unless args
+ (error "Keyword %s is missing an argument" keyword))
+ (setq args (cdr args))
+ (cond ((eq keyword :initialize)
+ (setq initialize value))
+ ((eq keyword :set)
+ (put symbol 'custom-set value))
+ ((eq keyword :get)
+ (put symbol 'custom-get value))
+ ((eq keyword :require)
+ (push value requests))
+ ((eq keyword :type)
+ (put symbol 'custom-type value))
+ ((eq keyword :options)
+ (if (get symbol 'custom-options)
+ ;; Slow safe code to avoid duplicates.
+ (mapcar (lambda (option)
+ (custom-add-option symbol option))
+ value)
+ ;; Fast code for the common case.
+ (put symbol 'custom-options (copy-sequence value))))
+ (t
+ (custom-handle-keyword symbol keyword value
+ 'custom-variable))))))
+ (put symbol 'custom-requests requests)
+ ;; Do the actual initialization.
+ (funcall initialize symbol value))
(run-hooks 'custom-define-hook)
symbol)
The following KEYWORD's are defined:
-:type VALUE should be a widget type.
+:type VALUE should be a widget type for editing the symbols value.
+ The default is `sexp'.
:options VALUE should be a list of valid members of the widget type.
:group VALUE should be a customization group.
Add SYMBOL to that group.
+:initialize VALUE should be a function used to initialize the
+ variable. It takes two arguments, the symbol and value
+ given in the `defcustom' call. The default is
+ `custom-initialize-default'
+:set VALUE should be a function to set the value of the symbol.
+ It takes two arguments, the symbol to set and the value to
+ give it. The default is `set-default'.
+:get VALUE should be a function to extract the value of symbol.
+ The function takes one argument, a symbol, and should return
+ the current value for that symbol. The default is
+ `default-value'.
+:require VALUE should be a feature symbol. Each feature will be
+ required after initialization, of the the user have saved this
+ option.
Read the section about customization in the Emacs Lisp manual for more
information."
(defun custom-declare-group (symbol members doc &rest args)
"Like `defgroup', but SYMBOL is evaluated as a normal argument."
+ (while members
+ (apply 'custom-add-to-group symbol (car members))
+ (setq members (cdr members)))
(put symbol 'custom-group (nconc members (get symbol 'custom-group)))
(when doc
(put symbol 'group-documentation doc))
(while args
(let ((entry (car args)))
(if (listp entry)
- (let ((symbol (nth 0 entry))
- (value (nth 1 entry))
- (now (nth 2 entry)))
+ (let* ((symbol (nth 0 entry))
+ (value (nth 1 entry))
+ (now (nth 2 entry))
+ (requests (nth 3 entry))
+ (set (or (get symbol 'custom-set) 'set-default)))
(put symbol 'saved-value (list value))
(cond (now
;; Rogue variable, set it now.
(put symbol 'force-value t)
- (set-default symbol (eval value)))
+ (funcall set symbol (eval value)))
((default-boundp symbol)
;; Something already set this, overwrite it.
- (set-default symbol (eval value))))
+ (funcall set symbol (eval value))))
+ (when requests
+ (put symbol 'custom-requests requests)
+ (mapcar 'require requests))
(setq args (cdr args)))
;; Old format, a plist of SYMBOL VALUE pairs.
(message "Warning: old format `custom-set-variables'")
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 1.84
+;; Version: 1.90
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
(require 'widget)
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl))
;;; Compatibility.
;; We have the old custom-library, hack around it!
(defmacro defgroup (&rest args) nil)
(defmacro defcustom (var value doc &rest args)
- `(defvar ,var ,value ,doc))
+ (` (defvar (, var) (, value) (, doc))))
(defmacro defface (&rest args) nil)
(define-widget-keywords :prefix :tag :load :link :options :type :group)
(when (fboundp 'copy-face)
(defface widget-field-face '((((class grayscale color)
(background light))
- (:background "light gray"))
+ (:background "gray85"))
(((class grayscale color)
(background dark))
(:background "dark gray"))
"Choose an item from a list.
First argument TITLE is the name of the list.
-Second argument ITEMS is an alist (NAME . VALUE).
+Second argument ITEMS is an list whose members are either
+ (NAME . VALUE), to indicate selectable items, or just strings to
+ indicate unselectable items.
Optional third argument EVENT is an input event.
The user is asked to choose between each NAME from the items alist,
(mapcar
(function
(lambda (x)
- (vector (car x) (list (car x)) t)))
+ (if (stringp x)
+ (vector x nil nil)
+ (vector (car x) (list (car x)) t))))
items)))))
(setq val (and val
(listp (event-object val))
(car (event-object val))))
(cdr (assoc val items))))
(t
+ (setq items (remove-if 'stringp items))
(let ((val (completing-read (concat title ": ") items nil t)))
(if (stringp val)
(let ((try (try-completion val items)))
(throw 'child child)))
nil)))
+;;; Helper functions.
+;;
+;; These are widget specific.
+
+;;;###autoload
+(defun widget-prompt-value (widget prompt &optional value unbound)
+ "Prompt for a value matching WIDGET, using PROMPT.
+The current value is assumed to be VALUE, unless UNBOUND is non-nil."
+ (unless (listp widget)
+ (setq widget (list widget)))
+ (setq widget (widget-convert widget))
+ (let ((answer (widget-apply widget :prompt-value prompt value unbound)))
+ (unless (widget-apply widget :match answer)
+ (error "Value does not match %S type." (car widget)))
+ answer))
+
;;; Widget text specifications.
;;
;; These functions are for specifying text properties.
(defmacro widget-specify-insert (&rest form)
;; Execute FORM without inheriting any text properties.
- `(save-restriction
+ (`
+ (save-restriction
(let ((inhibit-read-only t)
result
after-change-functions)
(narrow-to-region (- (point) 2) (point))
(widget-specify-none (point-min) (point-max))
(goto-char (1+ (point-min)))
- (setq result (progn ,@form))
+ (setq result (progn (,@ form)))
(delete-region (point-min) (1+ (point-min)))
(delete-region (1- (point-max)) (point-max))
(goto-char (point-max))
- result)))
+ result))))
(defface widget-inactive-face '((((class grayscale color)
(background dark))
(unless (widget-get widget :inactive)
(let ((overlay (make-overlay from to nil t nil)))
(overlay-put overlay 'face 'widget-inactive-face)
- (overlay-put overlay 'evaporate 't)
+ (overlay-put overlay 'evaporate t)
+ (overlay-put overlay 'priority 100)
(overlay-put overlay (if (string-match "XEmacs" emacs-version)
'read-only
'modification-hooks) '(widget-overlay-inactive))
(if (widget-apply widget :active)
(widget-apply widget :action event)
(error "Attempt to perform action on inactive widget")))
-
+
;;; Glyphs.
(defcustom widget-glyph-directory (concat data-directory "custom/")
(t
(error "No buttons or fields found"))))))
(setq button (widget-at (point)))
- (if (and button (widget-get button :tab-order)
- (< (widget-get button :tab-order) 0))
+ (if (or (and button (widget-get button :tab-order)
+ (< (widget-get button :tab-order) 0))
+ (and button (not (widget-apply button :active))))
(setq arg (1+ arg))))))
(while (< arg 0)
(if (= (point-min) (point))
(button (goto-char button))
(field (goto-char field)))
(setq button (widget-at (point)))
- (if (and button (widget-get button :tab-order)
- (< (widget-get button :tab-order) 0))
+ (if (or (and button (widget-get button :tab-order)
+ (< (widget-get button :tab-order) 0))
+ (and button (not (widget-apply button :active))))
(setq arg (1- arg)))))
(widget-echo-help (point))
(run-hooks 'widget-move-hook))
:activate 'widget-specify-active
:deactivate 'widget-default-deactivate
:action 'widget-default-action
- :notify 'widget-default-notify)
+ :notify 'widget-default-notify
+ :prompt-value 'widget-default-prompt-value)
(defun widget-default-create (widget)
"Create WIDGET at point in the current buffer."
(set-marker-insertion-type from t)
(set-marker-insertion-type to nil)
(widget-put widget :from from)
- (widget-put widget :to to))))
+ (widget-put widget :to to)))
+ (widget-clear-undo))
(defun widget-default-format-handler (widget escape)
;; We recognize the %h escape by default.
;; Kludge: this doesn't need to be true for empty formats.
(delete-region from to))
(set-marker from nil)
- (set-marker to nil)))
+ (set-marker to nil))
+ (widget-clear-undo))
(defun widget-default-value-set (widget value)
;; Recreate widget with new value.
;; Pass notification to parent.
(widget-default-action widget event))
+(defun widget-default-prompt-value (widget prompt value unbound)
+ ;; Read an arbitrary value. Stolen from `set-variable'.
+;; (let ((initial (if unbound
+;; nil
+;; ;; It would be nice if we could do a `(cons val 1)' here.
+;; (prin1-to-string (custom-quote value))))))
+ (eval-minibuffer prompt ))
+
;;; The `item' Widget.
(define-widget 'item 'default
(defun widget-info-link-action (widget &optional event)
"Open the info node specified by WIDGET."
- (Info-goto-node (widget-value widget)))
+ (Info-goto-node (widget-value widget))
+ ;; Steal button release event.
+ (if (and (fboundp 'button-press-event-p)
+ (fboundp 'next-command-event))
+ ;; XEmacs
+ (and event
+ (button-press-event-p event)
+ (next-command-event))
+ ;; Emacs
+ (when (memq 'down (event-modifiers event))
+ (read-event))))
;;; The `url-link' Widget.
(widget-value-set widget
(widget-apply current :value-to-external
(widget-get current :value)))
- (widget-apply widget :notify widget event)
- (widget-setup)))
- ;; Notify parent.
- (widget-apply widget :notify widget event)
- (widget-clear-undo))
+ (widget-apply widget :notify widget event)
+ (widget-setup))))
(defun widget-choice-validate (widget)
;; Valid if we have made a valid choice.
;; Toggle value.
(widget-value-set widget (not (widget-value widget)))
(widget-apply widget :notify widget event))
-
+
;;; The `checkbox' Widget.
(define-widget 'checkbox 'toggle
(define-widget 'const 'item
"An immutable sexp."
+ :prompt-value 'widget-const-prompt-value
:format "%t\n%d")
-(define-widget 'function-item 'item
+(defun widget-const-prompt-value (widget prompt value unbound)
+ ;; Return the value of the const.
+ (widget-value widget))
+
+(define-widget 'function-item 'const
"An immutable function name."
:format "%v\n%h"
:documentation-property (lambda (symbol)
(documentation symbol t)
(error nil))))
-(define-widget 'variable-item 'item
+(define-widget 'variable-item 'const
"An immutable variable name."
:format "%v\n%h"
:documentation-property 'variable-documentation)
(define-widget 'string 'editable-field
"A string"
+ :prompt-value 'widget-string-prompt-value
:tag "String"
:format "%[%t%]: %v")
+(defvar widget-string-prompt-value-history nil
+ "History of input to `widget-string-prompt-value'.")
+
+(defun widget-string-prompt-value (widget prompt value unbound)
+ ;; Read a string.
+ (read-string prompt (if unbound nil (cons value 1))
+ 'widget-string-prompt-value-history))
+
(define-widget 'regexp 'string
"A regular expression."
- ;; Should do validation.
+ :match 'widget-regexp-match
+ :validate 'widget-regexp-validate
:tag "Regexp")
+(defun widget-regexp-match (widget value)
+ ;; Match valid regexps.
+ (and (stringp value)
+ (condition-case data
+ (prog1 t
+ (string-match value ""))
+ (error nil))))
+
+(defun widget-regexp-validate (widget)
+ "Check that the value of WIDGET is a valid regexp."
+ (let ((val (widget-value widget)))
+ (condition-case data
+ (prog1 nil
+ (string-match val ""))
+ (error (widget-put widget :error (error-message-string data))
+ widget))))
+
(define-widget 'file 'string
"A file widget.
It will read a file name from the minibuffer when activated."
+ :prompt-value 'widget-file-prompt-value
:format "%[%t%]: %v"
:tag "File"
:action 'widget-file-action)
+(defun widget-file-prompt-value (widget prompt value unbound)
+ ;; Read file from minibuffer.
+ (abbreviate-file-name
+ (if unbound
+ (read-file-name prompt)
+ (let ((prompt2 (concat prompt "(default `" value "') "))
+ (dir (file-name-directory value))
+ (file (file-name-nondirectory value))
+ (must-match (widget-get widget :must-match)))
+ (read-file-name prompt2 dir nil must-match file)))))
+
(defun widget-file-action (widget &optional event)
;; Read a file name from the minibuffer.
(let* ((value (widget-value widget))
:validate 'widget-sexp-validate
:match (lambda (widget value) t)
:value-to-internal 'widget-sexp-value-to-internal
- :value-to-external (lambda (widget value) (read value)))
+ :value-to-external (lambda (widget value) (read value))
+ :prompt-value 'widget-sexp-prompt-value)
(defun widget-sexp-value-to-internal (widget value)
;; Use pp for printer representation.
(error (widget-put widget :error (error-message-string data))
widget)))))
+(defvar widget-sexp-prompt-value-history nil
+ "History of input to `widget-sexp-prompt-value'.")
+
+(defun widget-sexp-prompt-value (widget prompt value unbound)
+ ;; Read an arbitrary sexp.
+ (let ((found (read-string prompt
+ (if unbound nil (cons (prin1-to-string value) 1))
+ 'widget-sexp-prompt-value)))
+ (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
+ (erase-buffer)
+ (insert found)
+ (goto-char (point-min))
+ (let ((answer (read buffer)))
+ (unless (eobp)
+ (error "Junk at end of expression: %s"
+ (buffer-substring (point) (point-max))))
+ answer))))
+
(define-widget 'integer 'sexp
"An integer."
:tag "Integer"
:value 0
:size 1
:format "%{%t%}: %v\n"
- :type-error "This field should contain a character"
+ :valid-regexp "\\`.\\'"
+ :error "This field should contain a single character"
:value-to-internal (lambda (widget value)
(if (integerp value)
(char-to-string value)
(define-widget 'boolean 'toggle
"To be nil or non-nil, that is the question."
:tag "Boolean"
+ :prompt-value 'widget-boolean-prompt-value
:format "%{%t%}: %[%v%]\n")
+(defun widget-boolean-prompt-value (widget prompt value unbound)
+ ;; Toggle a boolean.
+ (cond (unbound
+ (y-or-n-p prompt))
+ (value
+ (message "Off")
+ nil)
+ (t
+ (message "On")
+ t)))
+
;;; The `color' Widget.
(define-widget 'color-item 'choice-item
projects / emacs.git / commitdiff