Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-23 21:37:34 +00:00
Code Issues Projects Releases Packages Wiki Activity

Synched with custom 1.90.

Browse source
This commit is contained in:
Per Abrahamsen 1997-04-24 16:53:55 +00:00
parent ee82af565d
commit 6d528fc505
5 changed files with 622 additions and 158 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

398
lisp/cus-edit.el
View file

@ -4,7 +4,7 @@
;;
;; 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.
@ -26,6 +26,8 @@
;;; Commentary:
;;
;; This file implements the code to create and edit customize buffers.
;;
;; See `custom.el'.
;;; Code:
@ -33,6 +35,11 @@
(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))
@ -355,10 +362,30 @@ Return a list suitable for use in `interactive'."
(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
@ -552,6 +579,74 @@ when the action is chosen.")
;;; 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."
@ -567,6 +662,21 @@ when the action is chosen.")
(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."
@ -617,7 +727,24 @@ If SYMBOL is nil, customize all faces."
;;;###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)
@ -630,7 +757,7 @@ If SYMBOL is nil, customize all faces."
(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)
@ -657,6 +784,8 @@ user-settable."
(custom-buffer-create found)
(error "No matches"))))
;;; Buffer.
;;;###autoload
(defun custom-buffer-create (options)
"Create a buffer containing OPTIONS.
@ -667,6 +796,7 @@ that option."
(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
@ -758,6 +888,7 @@ Make the modifications default for future sessions."
(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.
@ -939,6 +1070,7 @@ The list should be sorted most significant first."
"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)
@ -998,15 +1130,7 @@ Change the state of this item."
(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.
@ -1094,14 +1218,20 @@ Change the state of this item."
(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."
@ -1150,6 +1280,17 @@ Change the state of this item."
"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)))
@ -1203,8 +1344,10 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
(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)
@ -1234,7 +1377,7 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
((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
@ -1266,8 +1409,9 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
(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))
@ -1292,29 +1436,52 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
(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)))))
@ -1333,32 +1500,34 @@ Optional EVENT is the location for the menu."
(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))
@ -1366,12 +1535,12 @@ Optional EVENT is the location for the menu."
(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)
@ -1379,10 +1548,11 @@ Optional EVENT is the location for the menu."
(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)
@ -1391,9 +1561,10 @@ Optional EVENT is the location for the menu."
(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)
@ -1550,9 +1721,7 @@ Match frames with dark backgrounds.")
(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."
@ -1600,17 +1769,32 @@ Match frames with dark backgrounds.")
(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."
@ -1646,13 +1830,13 @@ when the action is chosen.")
"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)))))
@ -1865,27 +2049,44 @@ and so forth. The remaining group tags are shown with
(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)))))
@ -1986,17 +2187,26 @@ Leave point at the location of the call, or after the last expression."
(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")))))
@ -2037,6 +2247,22 @@ Leave point at the location of the call, or after the last expression."
(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'."
@ -2178,7 +2404,7 @@ The format is suitable for use with `easy-menu-define'."
(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

154
lisp/custom.el
View file

@ -4,7 +4,7 @@
;;
;; 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.
@ -38,7 +38,9 @@
(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'.
@ -46,14 +48,62 @@
;;; 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.
@ -62,29 +112,42 @@
(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)
@ -100,10 +163,25 @@ The remaining arguments should have the form
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."
@ -163,6 +241,9 @@ 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))
@ -285,17 +366,22 @@ the default value for the SYMBOL."
(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'")

35
lisp/wid-browse.el
View file

@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
;; Version: 1.84
;; Version: 1.90
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
@ -16,7 +16,7 @@
(require 'easymenu)
(require 'custom)
(require 'wid-edit)
(require 'cl)
(eval-when-compile (require 'cl))
(defgroup widget-browse nil
"Customization support for browsing widgets."
@ -245,6 +245,37 @@ VALUE is assumed to be a list of widgets."
(put :button 'widget-keyword-printer 'widget-browse-widget)
(put :args 'widget-keyword-printer 'widget-browse-sexps)
;;; Widget Minor Mode.
(defvar widget-minor-mode nil
"I non-nil, we are in Widget Minor Mode.")
(make-variable-buffer-local 'widget-minor-mode)
(defvar widget-minor-mode-map nil
"Keymap used in Widget Minor Mode.")
(unless widget-minor-mode-map
(setq widget-minor-mode-map (make-sparse-keymap))
(set-keymap-parent widget-minor-mode-map widget-keymap))
;;;###autoload
(defun widget-minor-mode (&optional arg)
"Togle minor mode for traversing widgets.
With arg, turn widget mode on if and only if arg is positive."
(interactive "P")
(cond ((null arg)
(setq widget-minor-mode (not widget-minor-mode)))
((<= 0 arg)
(setq widget-minor-mode nil))
(t
(setq widget-minor-mode t)))
(force-mode-line-update))
(add-to-list 'minor-mode-alist '(widget-minor-mode " Widget"))
(add-to-list 'minor-mode-map-alist
(cons 'widget-minor-mode widget-minor-mode-map))
;;; The End:
(provide 'wid-browse)

180
lisp/wid-edit.el
View file

@ -4,7 +4,7 @@
;;
;; 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.
@ -32,8 +32,7 @@
(require 'widget)
(eval-when-compile
(require 'cl))
(eval-when-compile (require 'cl))
;;; Compatibility.
@ -75,7 +74,7 @@ and `end-open' if it should sticky to the front."
;; 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)
@ -134,7 +133,7 @@ into the buffer visible in the event's window."
(defface widget-field-face '((((class grayscale color)
(background light))
(:background "light gray"))
(:background "gray85"))
(((class grayscale color)
(background dark))
(:background "dark gray"))
@ -184,7 +183,9 @@ Larger menus are read through the minibuffer."
"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,
@ -205,7 +206,9 @@ minibuffer."
(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))
@ -213,6 +216,7 @@ minibuffer."
(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)))
@ -235,6 +239,22 @@ This is only meaningful for radio buttons or checkboxes in a list."
(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.
@ -388,7 +408,8 @@ This is only meaningful for radio buttons or checkboxes in a list."
(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)
@ -396,11 +417,11 @@ This is only meaningful for radio buttons or checkboxes in a list."
(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))
@ -418,7 +439,8 @@ This is only meaningful for radio buttons or checkboxes in a list."
(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))
@ -503,7 +525,7 @@ ARGS are passed as extra arguments to the function."
(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/")
@ -800,8 +822,9 @@ ARG may be negative to move backward."
(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))
@ -838,8 +861,9 @@ ARG may be negative to move backward."
(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))
@ -1016,7 +1040,8 @@ With optional ARG, move across that many fields."
: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."
@ -1087,7 +1112,8 @@ With optional ARG, move across that many fields."
(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.
@ -1149,7 +1175,8 @@ With optional ARG, move across that many fields."
;; 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.
@ -1194,6 +1221,14 @@ With optional ARG, move across that many fields."
;; 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
@ -1297,7 +1332,17 @@ With optional ARG, move across that many fields."
(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.
@ -1507,11 +1552,8 @@ With optional ARG, move across that many fields."
(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.
@ -1567,7 +1609,7 @@ With optional ARG, move across that many fields."
;; Toggle value.
(widget-value-set widget (not (widget-value widget)))
(widget-apply widget :notify widget event))
;;; The `checkbox' Widget.
(define-widget 'checkbox 'toggle
@ -2222,9 +2264,14 @@ With optional ARG, move across that many fields."
(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)
@ -2232,28 +2279,67 @@ With optional ARG, move across that many fields."
(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))
@ -2303,7 +2389,8 @@ It will read a directory name from the minibuffer when activated."
: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.
@ -2337,6 +2424,24 @@ It will read a directory name from the minibuffer when activated."
(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"
@ -2354,7 +2459,8 @@ It will read a directory name from the minibuffer when activated."
: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)
@ -2432,8 +2538,20 @@ It will read a directory name from the minibuffer when activated."
(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

13
lisp/widget.el
View file

@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, extensions, faces, hypermedia
;; Version: 1.84
;; Version: 1.90
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
@ -44,8 +44,8 @@
(set (car keywords) (car keywords)))
(setq keywords (cdr keywords)))))))
(define-widget-keywords :text-format :deactivate :active :inactive
:activate :sibling-args :delete-button-args
(define-widget-keywords :prompt-value :text-format :deactivate :active
:inactive :activate :sibling-args :delete-button-args
:insert-button-args :append-button-args :button-args
:tag-glyph :off-glyph :on-glyph :valid-regexp
:secret :sample-face :sample-face-get :case-fold :widget-doc
@ -66,9 +66,11 @@
(autoload 'widget-apply "wid-edit")
(autoload 'widget-create "wid-edit")
(autoload 'widget-insert "wid-edit")
(autoload 'widget-prompt-value "wid-edit")
(autoload 'widget-browse "wid-browse" nil t)
(autoload 'widget-browse-other-window "wid-browse" nil t)
(autoload 'widget-browse-at "wid-browse" nil t))
(autoload 'widget-browse-at "wid-browse" nil t)
(autoload 'widget-minor-mode "wid-browse" nil t))
(defun define-widget (name class doc &rest args)
"Define a new widget type named NAME from CLASS.
@ -85,7 +87,8 @@ create identical widgets:
The third argument DOC is a documentation string for the widget."
(put name 'widget-type (cons class args))
(put name 'widget-documentation doc))
(put name 'widget-documentation doc)
name)
;;; The End.