Mercurial > emacs
changeset 17550:d6545cfb6c5a
Synched with custom 1.90.
| author | Per Abrahamsen <abraham@dina.kvl.dk> |
|---|---|
| date | Thu, 24 Apr 1997 16:53:55 +0000 |
| parents | f57de209f01b |
| children | 2738b57e4704 |
| files | lisp/cus-edit.el lisp/custom.el lisp/wid-browse.el lisp/wid-edit.el lisp/widget.el |
| diffstat | 5 files changed, 622 insertions(+), 158 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/cus-edit.el Thu Apr 24 02:58:11 1997 +0000 +++ b/lisp/cus-edit.el Thu Apr 24 16:53:55 1997 +0000 @@ -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 @@ (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 @@ ;;; 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." @@ -568,6 +663,21 @@ (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." (interactive (custom-variable-prompt)) @@ -617,7 +727,24 @@ ;;;###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 @@ (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 @@ (custom-buffer-create found) (error "No matches")))) +;;; Buffer. + ;;;###autoload (defun custom-buffer-create (options) "Create a buffer containing OPTIONS. @@ -667,6 +796,7 @@ (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 @@ (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 @@ "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 @@ (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 @@ (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 @@ "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 @@ (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 @@ ((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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ "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 @@ (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 @@ (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"))))) @@ -2038,6 +2248,22 @@ (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'." (custom-save-variables) @@ -2178,7 +2404,7 @@ (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
--- a/lisp/custom.el Thu Apr 24 02:58:11 1997 +0000 +++ b/lisp/custom.el Thu Apr 24 16:53:55 1997 +0000 @@ -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 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 @@ (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 @@ (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'")
--- a/lisp/wid-browse.el Thu Apr 24 02:58:11 1997 +0000 +++ b/lisp/wid-browse.el Thu Apr 24 16:53:55 1997 +0000 @@ -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 @@ (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)
--- a/lisp/wid-edit.el Thu Apr 24 02:58:11 1997 +0000 +++ b/lisp/wid-edit.el Thu Apr 24 16:53:55 1997 +0000 @@ -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 @@ ;; 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 @@ (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 @@ "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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ :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 @@ (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 @@ ;; 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 @@ ;; 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 @@ (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 @@ (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 @@ ;; 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 @@ (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 @@ (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 @@ :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 @@ (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 @@ :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 @@ (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
--- a/lisp/widget.el Thu Apr 24 02:58:11 1997 +0000 +++ b/lisp/widget.el Thu Apr 24 16:53:55 1997 +0000 @@ -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 @@ 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.