X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/46fa5a8374ea61d84a1f044522de9e17dd367e04..ae2777b77ab61c109b92e0b7fd00fc56f9afb61f:/lisp/cus-edit.el diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 43a8ca53ad..4d4fc08355 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1,10 +1,10 @@ -;;; cus-edit.el --- Tools for customization Emacs. +;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages. ;; ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.84 +;; Version: 1.9954 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -26,27 +26,38 @@ ;;; Commentary: ;; +;; This file implements the code to create and edit customize buffers. +;; ;; See `custom.el'. +;; No commands should have names starting with `custom-' because +;; that interferes with completion. Use `customize-' for commands +;; that the user will run with M-x, and `Custom-' for interactive commands. + ;;; Code: (require 'cus-face) (require 'wid-edit) (require 'easymenu) +(eval-when-compile (require 'cl)) -(defun custom-face-display-set (face spec &optional frame) - (face-spec-set face spec frame)) +(condition-case nil + (require 'cus-load) + (error nil)) -(defun custom-display-match-frame (display frame) - (face-spec-set-match-display display frame)) +(condition-case nil + (require 'cus-start) + (error nil)) -(define-widget-keywords :custom-prefixes :custom-menu :custom-show +(define-widget-keywords :custom-last :custom-prefix :custom-category + :custom-prefixes :custom-menu + :custom-show :custom-magic :custom-state :custom-level :custom-form :custom-set :custom-save :custom-reset-current :custom-reset-saved - :custom-reset-factory) + :custom-reset-standard) (put 'custom-define-hook 'custom-type 'hook) -(put 'custom-define-hook 'factory-value '(nil)) +(put 'custom-define-hook 'standard-value '(nil)) (custom-add-to-group 'customize 'custom-define-hook 'custom-variable) ;;; Customization Groups. @@ -95,6 +106,10 @@ :group 'external :group 'development) +(defgroup convenience nil + "Convenience features for faster editing." + :group 'emacs) + (defgroup programming nil "Support for programming in other languages." :group 'emacs) @@ -191,6 +206,10 @@ :group 'environment :group 'editing) +(defgroup x nil + "The X Window system." + :group 'environment) + (defgroup frames nil "Support for Emacs frames and window systems." :group 'environment) @@ -199,6 +218,10 @@ "Support editing files of data." :group 'emacs) +(defgroup files nil + "Support editing files." + :group 'emacs) + (defgroup wp nil "Word processing." :group 'emacs) @@ -236,6 +259,21 @@ :group 'customize :group 'faces) +(defgroup custom-browse nil + "Control customize browser." + :prefix "custom-" + :group 'customize) + +(defgroup custom-buffer nil + "Control customize buffers." + :prefix "custom-" + :group 'customize) + +(defgroup custom-menu nil + "Control customize menus." + :prefix "custom-" + :group 'customize) + (defgroup abbrev-mode nil "Word abbreviations mode." :group 'abbrev) @@ -303,18 +341,34 @@ (defgroup auto-save nil "Preventing accidential loss of data." - :group 'data) + :group 'files) (defgroup processes-basics nil "Basic stuff dealing with processes." :group 'processes) +(defgroup mule nil + "MULE Emacs internationalization." + :group 'i18n) + (defgroup windows nil "Windows within a frame." - :group 'processes) + :group 'environment) ;;; Utilities. +(defun custom-last (x &optional n) + ;; Stolen from `cl.el'. + "Returns the last link in the list LIST. +With optional argument N, returns Nth-to-last link (default 1)." + (if n + (let ((m 0) (p x)) + (while (consp p) (incf m) (pop p)) + (if (<= n 0) p + (if (< n m) (nthcdr (- m n) x) x))) + (while (consp (cdr x)) (pop x)) + x)) + (defun custom-quote (sexp) "Quote SEXP iff it is not self quoting." (if (or (memq sexp '(t nil)) @@ -352,12 +406,33 @@ Return a list suitable for use in `interactive'." (enable-recursive-minibuffers t) val) (setq val (completing-read - (if v - (format "Customize variable (default %s): " v) + (if (symbolp v) + (format "Customize option: (default %s) " v) "Customize variable: ") - obarray 'boundp t)) + obarray (lambda (symbol) + (and (boundp symbol) + (or (get symbol 'custom-type) + (user-variable-p symbol)))) t)) (list (if (equal val "") - v (intern val))))) + (if (symbolp v) v nil) + (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. @@ -366,7 +441,12 @@ Return a list suitable for use in `interactive'." (defcustom custom-unlispify-menu-entries t "Display menu entries as words instead of symbols if non nil." - :group 'customize + :group 'custom-menu + :type 'boolean) + +(defcustom custom-unlispify-remove-prefixes nil + "Non-nil means remove group prefixes from option names in buffer." + :group 'custom-menu :type 'boolean) (defun custom-unlispify-menu-entry (symbol &optional no-suffix) @@ -387,15 +467,16 @@ Return a list suitable for use in `interactive'." (re-search-forward "-p\\'" nil t)) (replace-match "" t t) (goto-char (point-min))) - (let ((prefixes custom-prefix-list) - prefix) - (while prefixes - (setq prefix (car prefixes)) - (if (search-forward prefix (+ (point) (length prefix)) t) - (progn - (setq prefixes nil) - (delete-region (point-min) (point))) - (setq prefixes (cdr prefixes))))) + (if custom-unlispify-remove-prefixes + (let ((prefixes custom-prefix-list) + prefix) + (while prefixes + (setq prefix (car prefixes)) + (if (search-forward prefix (+ (point) (length prefix)) t) + (progn + (setq prefixes nil) + (delete-region (point-min) (point))) + (setq prefixes (cdr prefixes)))))) (subst-char-in-region (point-min) (point-max) ?- ?\ t) (capitalize-region (point-min) (point-max)) (unless no-suffix @@ -405,7 +486,7 @@ Return a list suitable for use in `interactive'." (defcustom custom-unlispify-tag-names t "Display tag names as words instead of symbols if non nil." - :group 'customize + :group 'custom-buffer :type 'boolean) (defun custom-unlispify-tag-name (symbol) @@ -481,12 +562,90 @@ if that fails, the doc string with `custom-guess-doc-alist'." docs nil)))))) found)) +;;; Sorting. + +(defcustom custom-browse-sort-alphabetically nil + "If non-nil, sort members of each customization group alphabetically." + :type 'boolean + :group 'custom-browse) + +(defcustom custom-browse-order-groups nil + "If non-nil, order group members within each customization group. +If `first', order groups before non-groups. +If `last', order groups after non-groups." + :type '(choice (const first) + (const last) + (const :tag "none" nil)) + :group 'custom-browse) + +(defcustom custom-browse-only-groups nil + "If non-nil, show group members only within each customization group." + :type 'boolean + :group 'custom-browse) + +(defcustom custom-buffer-sort-alphabetically nil + "If non-nil, sort members of each customization group alphabetically." + :type 'boolean + :group 'custom-buffer) + +(defcustom custom-buffer-order-groups 'last + "If non-nil, order group members within each customization group. +If `first', order groups before non-groups. +If `last', order groups after non-groups." + :type '(choice (const first) + (const last) + (const :tag "none" nil)) + :group 'custom-buffer) + +(defcustom custom-menu-sort-alphabetically nil + "If non-nil, sort members of each customization group alphabetically." + :type 'boolean + :group 'custom-menu) + +(defcustom custom-menu-order-groups 'first + "If non-nil, order group members within each customization group. +If `first', order groups before non-groups. +If `last', order groups after non-groups." + :type '(choice (const first) + (const last) + (const :tag "none" nil)) + :group 'custom-menu) + +;;;###autoload (add-hook 'same-window-regexps "\\`\\*Customiz.*\\*\\'") + +(defun custom-sort-items (items sort-alphabetically order-groups) + "Return a sorted copy of ITEMS. +ITEMS should be a `custom-group' property. +If SORT-ALPHABETICALLY non-nil, sort alphabetically. +If ORDER-GROUPS is `first' order groups before non-groups, if `last' order +groups after non-groups, if nil do not order groups at all." + (sort (copy-sequence items) + (lambda (a b) + (let ((typea (nth 1 a)) (typeb (nth 1 b)) + (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b)))) + (cond ((not order-groups) + ;; Since we don't care about A and B order, maybe sort. + (when sort-alphabetically + (string-lessp namea nameb))) + ((eq typea 'custom-group) + ;; If B is also a group, maybe sort. Otherwise, order A and B. + (if (eq typeb 'custom-group) + (when sort-alphabetically + (string-lessp namea nameb)) + (eq order-groups 'first))) + ((eq typeb 'custom-group) + ;; Since A cannot be a group, order A and B. + (eq order-groups 'last)) + (sort-alphabetically + ;; Since A and B cannot be groups, sort. + (string-lessp namea nameb))))))) + ;;; Custom Mode Commands. (defvar custom-options nil "Customization widgets in the current buffer.") -(defun custom-set () +(defun Custom-set () "Set changes in all modified options." (interactive) (let ((children custom-options)) @@ -495,7 +654,7 @@ if that fails, the doc string with `custom-guess-doc-alist'." (widget-apply child :custom-set))) children))) -(defun custom-save () +(defun Custom-save () "Set all modified group members and save them." (interactive) (let ((children custom-options)) @@ -506,9 +665,9 @@ if that fails, the doc string with `custom-guess-doc-alist'." (custom-save-all)) (defvar custom-reset-menu - '(("Current" . custom-reset-current) - ("Saved" . custom-reset-saved) - ("Factory Settings" . custom-reset-factory)) + '(("Current" . Custom-reset-current) + ("Saved" . Custom-reset-saved) + ("Standard Settings" . Custom-reset-standard)) "Alist of actions for the `Reset' button. 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 @@ -523,7 +682,7 @@ when the action is chosen.") (if answer (funcall answer)))) -(defun custom-reset-current () +(defun Custom-reset-current (&rest ignore) "Reset all modified group members to their current value." (interactive) (let ((children custom-options)) @@ -532,53 +691,280 @@ when the action is chosen.") (widget-apply child :custom-reset-current))) children))) -(defun custom-reset-saved () +(defun Custom-reset-saved (&rest ignore) "Reset all modified or set group members to their saved value." (interactive) (let ((children custom-options)) (mapcar (lambda (child) (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-reset-current))) + (widget-apply child :custom-reset-saved))) children))) -(defun custom-reset-factory () - "Reset all modified, set, or saved group members to their factory settings." +(defun Custom-reset-standard (&rest ignore) + "Reset all modified, set, or saved group members to their standard settings." (interactive) (let ((children custom-options)) (mapcar (lambda (child) (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-reset-current))) + (widget-apply child :custom-reset-standard))) children))) ;;; 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 customize (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 (list (list symbol 'custom-group)))) +(defun customize-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 customize-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-save-variable (var val) + "Set the default for VARIABLE to VALUE, and save it for future sessions. +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 and ave variable: " + "Set and save value for %s as: ")) + (funcall (or (get var 'custom-set) 'set-default) var val) + (put var 'saved-value (list (custom-quote val))) + (custom-save-all)) + +;;;###autoload +(defun customize () + "Select a customization buffer which you can use to set user options. +User options are structured into \"groups\". +Initially the top-level group `Emacs' and its immediate subgroups +are shown; the contents of those subgroups are initially hidden." + (interactive) + (customize-group 'emacs)) + +;;;###autoload +(defun customize-group (group) + "Customize GROUP, which must be a customization group." + (interactive (list (let ((completion-ignore-case t)) + (completing-read "Customize group: (default emacs) " + obarray + (lambda (symbol) + (or (get symbol 'custom-loads) + (get symbol 'custom-group))) + t)))) + (when (stringp group) + (if (string-equal "" group) + (setq group 'emacs) + (setq group (intern group)))) + (or (get group 'custom-group) + (custom-load-symbol group)) + (let ((name (format "*Customize Group: %s*" + (custom-unlispify-tag-name group)))) + (if (get-buffer name) + (pop-to-buffer name) + (custom-buffer-create (list (list group 'custom-group)) + name + (concat " for group " + (custom-unlispify-tag-name group)))))) + +;;;###autoload +(defun customize-group-other-window (group) + "Customize GROUP, which must be a customization group." + (interactive (list (let ((completion-ignore-case t)) + (completing-read "Customize group: (default emacs) " + obarray + (lambda (symbol) + (or (get symbol 'custom-loads) + (get symbol 'custom-group))) + t)))) + (when (stringp group) + (if (string-equal "" group) + (setq group 'emacs) + (setq group (intern group)))) + (or (get group 'custom-group) + (custom-load-symbol group)) + (let ((name (format "*Customize Group: %s*" + (custom-unlispify-tag-name group)))) + (if (get-buffer name) + (let ((window (selected-window))) + (pop-to-buffer name) + (select-window window)) + (custom-buffer-create-other-window + (list (list group 'custom-group)) + name + (concat " for group " + (custom-unlispify-tag-name group)))))) + +;;;###autoload +(defalias 'customize-variable 'customize-option) ;;;###autoload -(defun customize-variable (symbol) - "Customize SYMBOL, which must be a variable." +(defun customize-option (symbol) + "Customize SYMBOL, which must be a user option variable." (interactive (custom-variable-prompt)) - (custom-buffer-create (list (list symbol 'custom-variable)))) + (custom-buffer-create (list (list symbol 'custom-variable)) + (format "*Customize Option: %s*" + (custom-unlispify-tag-name symbol)))) + +(defvar customize-changed-options-previous-release "20.2" + "Version for `customize-changed-options' to refer back to by default.") ;;;###autoload -(defun customize-variable-other-window (symbol) - "Customize SYMBOL, which must be a variable. +(defun customize-changed-options (since-version) + "Customize all user option variables changed in Emacs itself. +This includes new user option variables and faces, and new +customization groups, as well as older options and faces whose default +values have changed since the previous major Emacs release. + +With argument SINCE-VERSION (a string), customize all user option +variables that were added (or their meanings were changed) since that +version." + + (interactive "sCustomize options changed, since version (default all versions): ") + (if (equal since-version "") + (setq since-version nil)) + (unless since-version + (setq since-version customize-changed-options-previous-release)) + (let ((found nil) + (versions nil)) + (mapatoms (lambda (symbol) + (and (or (boundp symbol) + ;; For variables not yet loaded. + (get symbol 'standard-value) + ;; For groups the previous test fails, this one + ;; could be used to determine if symbol is a + ;; group. Is there a better way for this? + (get symbol 'group-documentation)) + (let ((version (get symbol 'custom-version))) + (and version + (or (null since-version) + (customize-version-lessp since-version version)) + (if (member version versions) + t + ;;; Collect all versions that we use. + (push version versions)))) + (setq found + ;; We have to set the right thing here, + ;; depending if we have a group or a + ;; variable. + (if (get symbol 'group-documentation) + (cons (list symbol 'custom-group) found) + (cons (list symbol 'custom-variable) found)))))) + (if (not found) + (error "No user option defaults have been changed since Emacs %s" + since-version) + (let ((flist nil)) + (while versions + (push (copy-sequence + (cdr (assoc (car versions) custom-versions-load-alist))) + flist) + (setq versions (cdr versions))) + (put 'custom-versions-load-alist 'custom-loads + ;; Get all the files that correspond to element from the + ;; VERSIONS list. This could use some simplification. + (apply 'nconc flist))) + ;; Because we set all the files needed to be loaded as a + ;; `custom-loads' property to `custom-versions-load-alist' this + ;; call will actually load them. + (custom-load-symbol 'custom-versions-load-alist) + ;; Clean up + (put 'custom-versions-load-alist 'custom-loads nil) + (custom-buffer-create (custom-sort-items found t 'first) + "*Customize Changed Options*")))) + +(defun customize-version-lessp (version1 version2) + ;; In case someone made a mistake and left out the quotes + ;; in the :version value. + (if (numberp version2) + (setq version2 (prin1-to-string version2))) + (let (major1 major2 minor1 minor2) + (string-match "\\([0-9]+\\)[.]\\([0-9]+\\)" version1) + (setq major1 (read (match-string 1 version1))) + (setq minor1 (read (match-string 2 version1))) + (string-match "\\([0-9]+\\)[.]\\([0-9]+\\)" version2) + (setq major2 (read (match-string 1 version2))) + (setq minor2 (read (match-string 2 version2))) + (or (< major1 major2) + (and (= major1 major2) + (< minor1 minor2))))) + +;;;###autoload +(defalias 'customize-variable-other-window 'customize-option-other-window) + +;;;###autoload +(defun customize-option-other-window (symbol) + "Customize SYMBOL, which must be a user option variable. Show the buffer in another window, but don't select it." (interactive (custom-variable-prompt)) - (custom-buffer-create-other-window (list (list symbol 'custom-variable)))) + (custom-buffer-create-other-window + (list (list symbol 'custom-variable)) + (format "*Customize Option: %s*" (custom-unlispify-tag-name symbol)))) ;;;###autoload (defun customize-face (&optional symbol) @@ -587,20 +973,19 @@ If SYMBOL is nil, customize all faces." (interactive (list (completing-read "Customize face: (default all) " obarray 'custom-facep))) (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) - (let ((found nil)) - (message "Looking for faces...") - (mapcar (lambda (symbol) - (setq found (cons (list symbol 'custom-face) found))) - (nreverse (mapcar 'intern - (sort (mapcar 'symbol-name (face-list)) - 'string<)))) - - (custom-buffer-create found)) - (if (stringp symbol) - (setq symbol (intern symbol))) + (custom-buffer-create (custom-sort-items + (mapcar (lambda (symbol) + (list symbol 'custom-face)) + (face-list)) + t nil) + "*Customize Faces*") + (when (stringp symbol) + (setq symbol (intern symbol))) (unless (symbolp symbol) (error "Should be a symbol %S" symbol)) - (custom-buffer-create (list (list symbol 'custom-face))))) + (custom-buffer-create (list (list symbol 'custom-face)) + (format "*Customize Face: %s*" + (custom-unlispify-tag-name symbol))))) ;;;###autoload (defun customize-face-other-window (&optional symbol) @@ -613,87 +998,221 @@ If SYMBOL is nil, customize all faces." (setq symbol (intern symbol))) (unless (symbolp symbol) (error "Should be a symbol %S" symbol)) - (custom-buffer-create-other-window (list (list symbol 'custom-face))))) + (custom-buffer-create-other-window + (list (list symbol 'custom-face)) + (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol))))) ;;;###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) + (push (list symbol 'custom-face) found)) + (and (get symbol 'customized-value) + (boundp symbol) + (push (list symbol 'custom-variable) found)))) + (if (not found) + (error "No customized user options") + (custom-buffer-create (custom-sort-items found t nil) + "*Customize Customized*")))) + +;;;###autoload +(defun customize-saved () + "Customize all already saved user options." (interactive) (let ((found nil)) (mapatoms (lambda (symbol) (and (get symbol 'saved-face) (custom-facep symbol) - (setq found (cons (list symbol 'custom-face) found))) + (push (list symbol 'custom-face) found)) (and (get symbol 'saved-value) (boundp symbol) - (setq found - (cons (list symbol 'custom-variable) found))))) - (if found - (custom-buffer-create found) - (error "No customized user options")))) + (push (list symbol 'custom-variable) found)))) + (if (not found ) + (error "No saved user options") + (custom-buffer-create (custom-sort-items found t nil) + "*Customize Saved*")))) ;;;###autoload (defun customize-apropos (regexp &optional all) "Customize all user options matching REGEXP. -If ALL (e.g., started with a prefix key), include options which are not -user-settable." +If ALL is `options', include only options. +If ALL is `faces', include only faces. +If ALL is `groups', include only groups. +If ALL is t (interactively, with prefix arg), include options which are not +user-settable, as well as faces and groups." (interactive "sCustomize regexp: \nP") (let ((found nil)) (mapatoms (lambda (symbol) (when (string-match regexp (symbol-name symbol)) - (when (get symbol 'custom-group) - (setq found (cons (list symbol 'custom-group) found))) - (when (custom-facep symbol) - (setq found (cons (list symbol 'custom-face) found))) - (when (and (boundp symbol) + (when (and (not (memq all '(faces options))) + (get symbol 'custom-group)) + (push (list symbol 'custom-group) found)) + (when (and (not (memq all '(options groups))) + (custom-facep symbol)) + (push (list symbol 'custom-face) found)) + (when (and (not (memq all '(groups faces))) + (boundp symbol) (or (get symbol 'saved-value) - (get symbol 'factory-value) - (if all - (get symbol 'variable-documentation) - (user-variable-p symbol)))) - (setq found - (cons (list symbol 'custom-variable) found)))))) - (if found - (custom-buffer-create found) - (error "No matches")))) + (get symbol 'standard-value) + (if (memq all '(nil options)) + (user-variable-p symbol) + (get symbol 'variable-documentation)))) + (push (list symbol 'custom-variable) found))))) + (if (not found) + (error "No matches") + (custom-buffer-create (custom-sort-items found t + custom-buffer-order-groups) + "*Customize Apropos*")))) + +;;;###autoload +(defun customize-apropos-options (regexp &optional arg) + "Customize all user options matching REGEXP. +With prefix arg, include options which are not user-settable." + (interactive "sCustomize regexp: \nP") + (customize-apropos regexp (or arg 'options))) + +;;;###autoload +(defun customize-apropos-faces (regexp) + "Customize all user faces matching REGEXP." + (interactive "sCustomize regexp: \n") + (customize-apropos regexp 'faces)) ;;;###autoload -(defun custom-buffer-create (options) +(defun customize-apropos-groups (regexp) + "Customize all user groups matching REGEXP." + (interactive "sCustomize regexp: \n") + (customize-apropos regexp 'groups)) + +;;; Buffer. + +(defcustom custom-buffer-style 'links + "Control the presentation style for customization buffers. +The value should be a symbol, one of: + +brackets: groups nest within each other with big horizontal brackets. +links: groups have links to subgroups." + :type '(radio (const brackets) + (const links)) + :group 'custom-buffer) + +(defcustom custom-buffer-indent 3 + "Number of spaces to indent nested groups." + :type 'integer + :group 'custom-buffer) + +;;;###autoload +(defun custom-buffer-create (options &optional name description) "Create a buffer containing OPTIONS. +Optional NAME is the name of the buffer. OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where SYMBOL is a customization option, and WIDGET is a widget for editing that option." - (kill-buffer (get-buffer-create "*Customization*")) - (switch-to-buffer (get-buffer-create "*Customization*")) - (custom-buffer-create-internal options)) + (unless name (setq name "*Customization*")) + (kill-buffer (get-buffer-create name)) + (pop-to-buffer (get-buffer-create name)) + (custom-buffer-create-internal options description)) -(defun custom-buffer-create-other-window (options) +;;;###autoload +(defun custom-buffer-create-other-window (options &optional name description) "Create a buffer containing OPTIONS. +Optional NAME is the name of the buffer. OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where SYMBOL is a customization option, and WIDGET is a widget for editing that option." - (kill-buffer (get-buffer-create "*Customization*")) - (let ((window (selected-window))) - (switch-to-buffer-other-window (get-buffer-create "*Customization*")) - (custom-buffer-create-internal options) + (unless name (setq name "*Customization*")) + (kill-buffer (get-buffer-create name)) + (let ((window (selected-window)) + (pop-up-windows t) + (special-display-buffer-names nil) + (special-display-regexps nil) + (same-window-buffer-names nil) + (same-window-regexps nil)) + (pop-to-buffer (get-buffer-create name)) + (custom-buffer-create-internal options description) (select-window window))) - -(defun custom-buffer-create-internal (options) +(defcustom custom-reset-button-menu nil + "If non-nil, only show a single reset button in customize buffers. +This button will have a menu with all three reset operations." + :type 'boolean + :group 'custom-buffer) + +(defun custom-buffer-create-internal (options &optional description) (message "Creating customization buffer...") (custom-mode) - (widget-insert "This is a customization buffer. -Push RET or click mouse-2 on the word ") - ;; (put-text-property 1 2 'start-open nil) + (widget-insert "This is a customization buffer") + (if description + (widget-insert description)) + (widget-insert ". +Square brackets show active fields; type RET or click mouse-1 +on an active field to invoke its action. Editing an option value +changes the text in the buffer; invoke the State button and +choose the Set operation to set the option value. +Invoke ") (widget-create 'info-link - :tag "help" + :tag "Help" :help-echo "Read the online help." - "(custom)The Customization Buffer") + "(emacs)Easy Customization") (widget-insert " for more information.\n\n") + (message "Creating customization buttons...") + (widget-insert "Operate on everything in this buffer:\n ") + (widget-create 'push-button + :tag "Set for Current Session" + :help-echo "\ +Make your editing in this buffer take effect for this session." + :action (lambda (widget &optional event) + (Custom-set))) + (widget-insert " ") + (widget-create 'push-button + :tag "Save for Future Sessions" + :help-echo "\ +Make your editing in this buffer take effect for future Emacs sessions." + :action (lambda (widget &optional event) + (Custom-save))) + (if custom-reset-button-menu + (progn + (widget-insert " ") + (widget-create 'push-button + :tag "Reset" + :help-echo "Show a menu with reset operations." + :mouse-down-action (lambda (&rest junk) t) + :action (lambda (widget &optional event) + (custom-reset event)))) + (widget-insert "\n ") + (widget-create 'push-button + :tag "Reset" + :help-echo "\ +Reset all edited text in this buffer to reflect current values." + :action 'Custom-reset-current) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset to Saved" + :help-echo "\ +Reset all values in this buffer to their saved settings." + :action 'Custom-reset-saved) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset to Standard" + :help-echo "\ +Reset all values in this buffer to their standard settings." + :action 'Custom-reset-standard)) + (widget-insert " ") + (widget-create 'push-button + :tag "Bury Buffer" + :help-echo "Bury the buffer." + :action (lambda (widget &optional event) + (bury-buffer))) + (widget-insert "\n\n") + (message "Creating customization items...") (setq custom-options (if (= (length options) 1) (mapcar (lambda (entry) (widget-create (nth 1 entry) + :documentation-shown t :custom-state 'unknown :tag (custom-unlispify-tag-name (nth 0 entry)) @@ -703,7 +1222,7 @@ Push RET or click mouse-2 on the word ") (length (length options))) (mapcar (lambda (entry) (prog2 - (message "Creating customization items %2d%%..." + (message "Creating customization items ...%2d%%" (/ (* 100.0 count) length)) (widget-create (nth 1 entry) :tag (custom-unlispify-tag-name @@ -716,50 +1235,118 @@ Push RET or click mouse-2 on the word ") options)))) (unless (eq (preceding-char) ?\n) (widget-insert "\n")) - (widget-insert "\n") - (message "Creating customization magic...") - (mapcar 'custom-magic-reset custom-options) - (message "Creating customization buttons...") - (widget-create 'push-button - :tag "Set" - :help-echo "Set all modifications for this session." - :action (lambda (widget &optional event) - (custom-set))) - (widget-insert " ") - (widget-create 'push-button - :tag "Save" - :help-echo "\ -Make the modifications default for future sessions." - :action (lambda (widget &optional event) - (custom-save))) - (widget-insert " ") - (widget-create 'push-button - :tag "Reset" - :help-echo "Undo all modifications." - :action (lambda (widget &optional event) - (custom-reset event))) - (widget-insert " ") - (widget-create 'push-button - :tag "Done" - :help-echo "Bury the buffer." - :action (lambda (widget &optional event) - (bury-buffer) - ;; 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))))) - (widget-insert "\n") + (message "Creating customization items ...%2d%%done" 100) + (unless (eq custom-buffer-style 'tree) + (mapcar 'custom-magic-reset custom-options)) (message "Creating customization setup...") (widget-setup) (goto-char (point-min)) (message "Creating customization buffer...done")) +;;; The Tree Browser. + +;;;###autoload +(defun customize-browse (&optional group) + "Create a tree browser for the customize hierarchy." + (interactive) + (unless group + (setq group 'emacs)) + (let ((name "*Customize Browser*")) + (kill-buffer (get-buffer-create name)) + (pop-to-buffer (get-buffer-create name))) + (custom-mode) + (widget-insert "\ +Square brackets show active fields; type RET or click mouse-1 +on an active field to invoke its action. +Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n") + (if custom-browse-only-groups + (widget-insert "\ +Invoke the [Group] button below to edit that item in another window.\n\n") + (widget-insert "Invoke the ") + (widget-create 'item + :format "%t" + :tag "[Group]" + :tag-glyph "folder") + (widget-insert ", ") + (widget-create 'item + :format "%t" + :tag "[Face]" + :tag-glyph "face") + (widget-insert ", and ") + (widget-create 'item + :format "%t" + :tag "[Option]" + :tag-glyph "option") + (widget-insert " buttons below to edit that +item in another window.\n\n")) + (let ((custom-buffer-style 'tree)) + (widget-create 'custom-group + :custom-last t + :custom-state 'unknown + :tag (custom-unlispify-tag-name group) + :value group)) + (goto-char (point-min))) + +(define-widget 'custom-browse-visibility 'item + "Control visibility of items in the customize tree browser." + :format "%[[%t]%]" + :action 'custom-browse-visibility-action) + +(defun custom-browse-visibility-action (widget &rest ignore) + (let ((custom-buffer-style 'tree)) + (custom-toggle-parent widget))) + +(define-widget 'custom-browse-group-tag 'push-button + "Show parent in other window when activated." + :tag "Group" + :tag-glyph "folder" + :action 'custom-browse-group-tag-action) + +(defun custom-browse-group-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-group-other-window (widget-value parent)))) + +(define-widget 'custom-browse-variable-tag 'push-button + "Show parent in other window when activated." + :tag "Option" + :tag-glyph "option" + :action 'custom-browse-variable-tag-action) + +(defun custom-browse-variable-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-variable-other-window (widget-value parent)))) + +(define-widget 'custom-browse-face-tag 'push-button + "Show parent in other window when activated." + :tag "Face" + :tag-glyph "face" + :action 'custom-browse-face-tag-action) + +(defun custom-browse-face-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-face-other-window (widget-value parent)))) + +(defconst custom-browse-alist '((" " "space") + (" | " "vertical") + ("-\\ " "top") + (" |-" "middle") + (" `-" "bottom"))) + +(defun custom-browse-insert-prefix (prefix) + "Insert PREFIX. On XEmacs convert it to line graphics." + (if nil ; (string-match "XEmacs" emacs-version) + (progn + (insert "*") + (while (not (string-equal prefix "")) + (let ((entry (substring prefix 0 3))) + (setq prefix (substring prefix 3)) + (let ((overlay (make-overlay (1- (point)) (point) nil t nil)) + (name (nth 1 (assoc entry custom-browse-alist)))) + (overlay-put overlay 'end-glyph (widget-glyph-find name entry)) + (overlay-put overlay 'start-open t) + (overlay-put overlay 'end-open t))))) + (insert prefix))) + ;;; Modification of Basic Widgets. ;; ;; We add extra properties to the basic widgets needed here. This is @@ -788,61 +1375,79 @@ Make the modifications default for future sessions." ;;; The `custom-magic' Widget. +(defgroup custom-magic-faces nil + "Faces used by the magic button." + :group 'custom-faces + :group 'custom-buffer) + (defface custom-invalid-face '((((class color)) (:foreground "yellow" :background "red")) (t (:bold t :italic t :underline t))) - "Face used when the customize item is invalid.") + "Face used when the customize item is invalid." + :group 'custom-magic-faces) (defface custom-rogue-face '((((class color)) (:foreground "pink" :background "black")) (t (:underline t))) - "Face used when the customize item is not defined for customization.") + "Face used when the customize item is not defined for customization." + :group 'custom-magic-faces) (defface custom-modified-face '((((class color)) (:foreground "white" :background "blue")) (t (:italic t :bold))) - "Face used when the customize item has been modified.") + "Face used when the customize item has been modified." + :group 'custom-magic-faces) (defface custom-set-face '((((class color)) (:foreground "blue" :background "white")) (t (:italic t))) - "Face used when the customize item has been set.") + "Face used when the customize item has been set." + :group 'custom-magic-faces) (defface custom-changed-face '((((class color)) (:foreground "white" :background "blue")) (t (:italic t))) - "Face used when the customize item has been changed.") + "Face used when the customize item has been changed." + :group 'custom-magic-faces) (defface custom-saved-face '((t (:underline t))) - "Face used when the customize item has been saved.") + "Face used when the customize item has been saved." + :group 'custom-magic-faces) -(defcustom custom-magic-alist '((nil "#" underline "\ +(defconst custom-magic-alist '((nil "#" underline "\ uninitialized, you should not see this.") - (unknown "?" italic "\ + (unknown "?" italic "\ unknown, you should not see this.") - (hidden "-" default "\ -hidden, press the state button to show.") - (invalid "x" custom-invalid-face "\ -the value displayed for this item is invalid and cannot be set.") - (modified "*" custom-modified-face "\ -you have edited the item, and can now set it.") - (set "+" custom-set-face "\ -you have set this item, but not saved it.") - (changed ":" custom-changed-face "\ -this item has been changed outside customize.") - (saved "!" custom-saved-face "\ -this item has been saved.") - (rogue "@" custom-rogue-face "\ -this item is not prepared for customization.") - (factory " " nil "\ -this item is unchanged from its factory setting.")) + (hidden "-" default "\ +hidden, invoke \"Show\" in the previous line to show." "\ +group now hidden, invoke \"Show\", above, to show contents.") + (invalid "x" custom-invalid-face "\ +the value displayed for this %c is invalid and cannot be set.") + (modified "*" custom-modified-face "\ +you have edited the value as text, but you have not set the %c." "\ +you have edited something in this group, but not set it.") + (set "+" custom-set-face "\ +you have set this %c, but not saved it for future sessions." "\ +something in this group has been set, but not saved.") + (changed ":" custom-changed-face "\ +this %c has been changed outside the customize buffer." "\ +something in this group has been changed outside customize.") + (saved "!" custom-saved-face "\ +this %c has been set and saved." "\ +something in this group has been set and saved.") + (rogue "@" custom-rogue-face "\ +this %c has not been changed with customize." "\ +something in this group is not prepared for customization.") + (standard " " nil "\ +this %c is unchanged from its standard setting." "\ +visible group members are all at standard settings.")) "Alist of customize option states. -Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where +Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where STATE is one of the following symbols: @@ -864,121 +1469,127 @@ STATE is one of the following symbols: This item is marked for saving. `rogue' This item has no customization information. -`factory' - This item is unchanged from the factory default. +`standard' + This item is unchanged from the standard setting. MAGIC is a string used to present that state. FACE is a face used to present the state. -DESCRIPTION is a string describing the state. - -The list should be sorted most significant first." - :type '(list (checklist :inline t - (group (const nil) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const unknown) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const hidden) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const invalid) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const modified) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const set) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const changed) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const saved) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const rogue) - (string :tag "Magic") - face - (string :tag "Description")) - (group (const factory) - (string :tag "Magic") - face - (string :tag "Description"))) - (editable-list :inline t - (group symbol - (string :tag "Magic") - face - (string :tag "Description")))) - :group 'customize - :group 'custom-faces) +ITEM-DESC is a string describing the state for options. + +GROUP-DESC is a string describing the state for groups. If this is +left out, ITEM-DESC will be used. + +The string %c in either description will be replaced with the +category of the item. These are `group'. `option', and `face'. + +The list should be sorted most significant first.") (defcustom custom-magic-show 'long - "Show long description of the state of each customization option." + "If non-nil, show textual description of the state. +If `long', show a full-line description, not just one word." :type '(choice (const :tag "no" nil) - (const short) - (const long)) - :group 'customize) - -(defcustom custom-magic-show-button t - "Show a magic button indicating the state of each customization option." + (const long) + (other :tag "short" short)) + :group 'custom-buffer) + +(defcustom custom-magic-show-hidden '(option face) + "Control whether the State button is shown for hidden items. +The value should be a list with the custom categories where the State +button should be visible. Possible categories are `group', `option', +and `face'." + :type '(set (const group) (const option) (const face)) + :group 'custom-buffer) + +(defcustom custom-magic-show-button nil + "Show a \"magic\" button indicating the state of each customization option." :type 'boolean - :group 'customize) + :group 'custom-buffer) (define-widget 'custom-magic 'default "Show and manipulate state for a customization option." :format "%v" - :action 'widget-choice-item-action + :action 'widget-parent-action + :notify 'ignore :value-get 'ignore :value-create 'custom-magic-value-create :value-delete 'widget-children-value-delete) +(defun widget-magic-mouse-down-action (widget &optional event) + ;; Non-nil unless hidden. + (not (eq (widget-get (widget-get (widget-get widget :parent) :parent) + :custom-state) + 'hidden))) + (defun custom-magic-value-create (widget) ;; Create compact status report for WIDGET. (let* ((parent (widget-get widget :parent)) (state (widget-get parent :custom-state)) + (hidden (eq state 'hidden)) (entry (assq state custom-magic-alist)) (magic (nth 1 entry)) (face (nth 2 entry)) - (text (nth 3 entry)) - (lisp (eq (widget-get parent :custom-form) 'lisp)) + (category (widget-get parent :custom-category)) + (text (or (and (eq category 'group) + (nth 4 entry)) + (nth 3 entry))) + (form (widget-get parent :custom-form)) children) - (when custom-magic-show - (push (widget-create-child-and-convert widget 'choice-item - :help-echo "\ -Change the state of this item." - :format "%[%t%]" - :tag "State") + (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text) + (setq text (concat (match-string 1 text) + (symbol-name category) + (match-string 2 text)))) + (when (and custom-magic-show + (or (not hidden) + (memq category custom-magic-show-hidden))) + (insert " ") + (when (and (eq category 'group) + (not (and (eq custom-buffer-style 'links) + (> (widget-get parent :custom-level) 1)))) + (insert-char ?\ (* custom-buffer-indent + (widget-get parent :custom-level)))) + (push (widget-create-child-and-convert + widget 'choice-item + :help-echo "Change the state of this item." + :format (if hidden "%t" "%[%t%]") + :button-prefix 'widget-push-button-prefix + :button-suffix 'widget-push-button-suffix + :mouse-down-action 'widget-magic-mouse-down-action + :tag "State") children) (insert ": ") - (if (eq custom-magic-show 'long) - (insert text) - (insert (symbol-name state))) - (when lisp - (insert " (lisp)")) + (let ((start (point))) + (if (eq custom-magic-show 'long) + (insert text) + (insert (symbol-name state))) + (cond ((eq form 'lisp) + (insert " (lisp)")) + ((eq form 'mismatch) + (insert " (mismatch)"))) + (put-text-property start (point) 'face 'custom-state-face)) (insert "\n")) + (when (and (eq category 'group) + (not (and (eq custom-buffer-style 'links) + (> (widget-get parent :custom-level) 1)))) + (insert-char ?\ (* custom-buffer-indent + (widget-get parent :custom-level)))) (when custom-magic-show-button (when custom-magic-show (let ((indent (widget-get parent :indent))) (when indent (insert-char ? indent)))) - (push (widget-create-child-and-convert widget 'choice-item - :button-face face - :help-echo "Change the state." - :format "%[%t%]" - :tag (if lisp - (concat "(" magic ")") - (concat "[" magic "]"))) + (push (widget-create-child-and-convert + widget 'choice-item + :mouse-down-action 'widget-magic-mouse-down-action + :button-face face + :button-prefix "" + :button-suffix "" + :help-echo "Change the state." + :format (if hidden "%t" "%[%t%]") + :tag (if (memq form '(lisp mismatch)) + (concat "(" magic ")") + (concat "[" magic "]"))) children) (insert " ")) (widget-put widget :children children))) @@ -988,41 +1599,39 @@ Change the state of this item." (let ((magic (widget-get widget :custom-magic))) (widget-value-set magic (widget-value magic)))) -;;; The `custom-level' Widget. +;;; The `custom' Widget. -(define-widget 'custom-level 'item - "The custom level buttons." - :format "%[%t%]" - :help-echo "Expand or collapse this item." - :action 'custom-level-action) +(defface custom-button-face nil + "Face used for buttons in customization buffers." + :group 'custom-faces) -(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))) +(defface custom-documentation-face nil + "Face used for documentation strings in customization buffers." + :group 'custom-faces) -;;; The `custom' Widget. +(defface custom-state-face '((((class color) + (background dark)) + (:foreground "lime green")) + (((class color) + (background light)) + (:foreground "dark green")) + (t nil)) + "Face used for State descriptions in the customize buffer." + :group 'custom-faces) (define-widget 'custom 'default "Customize a user option." + :format "%v" :convert-widget 'custom-convert-widget - :format "%l%[%t%]: %v%m%h%a" - :format-handler 'custom-format-handler :notify 'custom-notify + :custom-prefix "" :custom-level 1 :custom-state 'hidden :documentation-property 'widget-subclass-responsibility :value-create 'widget-subclass-responsibility :value-delete 'widget-children-value-delete - :value-get 'widget-item-value-get - :validate 'widget-editable-list-validate + :value-get 'widget-value-value-get + :validate 'widget-children-validate :match (lambda (widget value) (symbolp value))) (defun custom-convert-widget (widget) @@ -1035,83 +1644,44 @@ Change the state of this item." (widget-put widget :args nil))) widget) -(defun custom-format-handler (widget escape) - ;; We recognize extra escape sequences. - (let* ((buttons (widget-get widget :buttons)) - (state (widget-get widget :custom-state)) - (level (widget-get widget :custom-level))) - (cond ((eq escape ?l) - (when level - (push (widget-create-child-and-convert - widget 'custom-level (make-string level ?*)) - buttons) - (widget-insert " ") - (widget-put widget :buttons buttons))) - ((eq escape ?L) - (when (eq state 'hidden) - (widget-insert " ..."))) - ((eq escape ?m) - (and (eq (preceding-char) ?\n) - (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (let ((magic (widget-create-child-and-convert - widget 'custom-magic nil))) - (widget-put widget :custom-magic magic) - (push magic buttons) - (widget-put widget :buttons buttons))) - ((eq escape ?a) - (let* ((symbol (widget-get widget :value)) - (links (get symbol 'custom-links)) - (many (> (length links) 2))) - (when links - (and (eq (preceding-char) ?\n) - (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (insert "See also ") - (while links - (push (widget-create-child-and-convert widget (car links)) - buttons) - (setq links (cdr links)) - (cond ((null links) - (insert ".\n")) - ((null (cdr links)) - (if many - (insert ", and ") - (insert " and "))) - (t - (insert ", ")))) - (widget-put widget :buttons buttons)))) - (t - (widget-default-format-handler widget escape))))) - (defun custom-notify (widget &rest args) "Keep track of changes." - (unless (memq (widget-get widget :custom-state) '(nil unknown hidden)) - (widget-put widget :custom-state 'modified)) - (let ((buffer-undo-list t)) - (custom-magic-reset widget)) - (apply 'widget-default-notify widget args)) + (let ((state (widget-get widget :custom-state))) + (unless (eq state 'modified) + (unless (memq state '(nil unknown hidden)) + (widget-put widget :custom-state 'modified)) + (custom-magic-reset widget) + (apply 'widget-default-notify widget args)))) (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 + (if (> column 0) + (goto-line line) + (goto-line (1+ line))) + (move-to-column column)) + (error nil))))) (defun custom-redraw-magic (widget) "Redraw WIDGET state with current settings." (while widget (let ((magic (widget-get widget :custom-magic))) - (unless magic - (debug)) - (widget-value-set magic (widget-value magic)) - (when (setq widget (widget-get widget :group)) - (custom-group-state-update widget)))) + (cond (magic + (widget-value-set magic (widget-value magic)) + (when (setq widget (widget-get widget :group)) + (custom-group-state-update widget))) + (t + (setq widget nil))))) (widget-setup)) (defun custom-show (widget value) @@ -1140,19 +1710,127 @@ Change the state of this item." (condition-case nil (require load) (error nil))) + ;; Don't reload a file already loaded. + ((and (boundp 'preloaded-file-list) + (member load preloaded-file-list))) ((assoc load load-history)) + ((assoc (locate-library load) load-history)) (t (condition-case nil - (load-library load) + ;; Without this, we would load cus-edit recursively. + ;; We are still loading it when we call this, + ;; and it is not in load-history yet. + (or (equal load "cus-edit") + (load-library load)) (error nil)))))))) (defun custom-load-widget (widget) "Load all dependencies for WIDGET." (custom-load-symbol (widget-value widget))) +(defun custom-unloaded-symbol-p (symbol) + "Return non-nil if the dependencies of SYMBOL has not yet been loaded." + (let ((found nil) + (loads (get symbol 'custom-loads)) + load) + (while loads + (setq load (car loads) + loads (cdr loads)) + (cond ((symbolp load) + (unless (featurep load) + (setq found t))) + ((assoc load load-history)) + ((assoc (locate-library load) load-history) + (message nil)) + (t + (setq found t)))) + found)) + +(defun custom-unloaded-widget-p (widget) + "Return non-nil if the dependencies of WIDGET has not yet been loaded." + (custom-unloaded-symbol-p (widget-value widget))) + +(defun custom-toggle-hide (widget) + "Toggle visibility of WIDGET." + (custom-load-widget 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 :documentation-shown nil) + (widget-put widget :custom-state 'hidden))) + (custom-redraw widget) + (widget-setup))) + +(defun custom-toggle-parent (widget &rest ignore) + "Toggle visibility of parent of WIDGET." + (custom-toggle-hide (widget-get widget :parent))) + +(defun custom-add-see-also (widget &optional prefix) + "Add `See also ...' to WIDGET if there are any links. +Insert PREFIX first if non-nil." + (let* ((symbol (widget-get widget :value)) + (links (get symbol 'custom-links)) + (many (> (length links) 2)) + (buttons (widget-get widget :buttons)) + (indent (widget-get widget :indent))) + (when links + (when indent + (insert-char ?\ indent)) + (when prefix + (insert prefix)) + (insert "See also ") + (while links + (push (widget-create-child-and-convert widget (car links)) + buttons) + (setq links (cdr links)) + (cond ((null links) + (insert ".\n")) + ((null (cdr links)) + (if many + (insert ", and ") + (insert " and "))) + (t + (insert ", ")))) + (widget-put widget :buttons buttons)))) + +(defun custom-add-parent-links (widget &optional initial-string) + "Add \"Parent groups: ...\" to WIDGET if the group has parents. +The value if non-nil if any parents were found. +If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." + (let ((name (widget-value widget)) + (type (widget-type widget)) + (buttons (widget-get widget :buttons)) + (start (point)) + found) + (insert (or initial-string "Parent groups:")) + (mapatoms (lambda (symbol) + (let ((entry (assq name (get symbol 'custom-group)))) + (when (eq (nth 1 entry) type) + (insert " ") + (push (widget-create-child-and-convert + widget 'custom-group-link + :tag (custom-unlispify-tag-name symbol) + symbol) + buttons) + (setq found t))))) + (widget-put widget :buttons buttons) + (if found + (insert "\n") + (delete-region start (point))) + found)) + ;;; The `custom-variable' Widget. -(defface custom-variable-sample-face '((t (:underline t))) +(defface custom-variable-tag-face '((((class color) + (background dark)) + (:foreground "light blue" :underline t)) + (((class color) + (background light)) + (:foreground "blue" :underline t)) + (t (:underline t))) "Face used for unpushable variable tags." :group 'custom-faces) @@ -1160,28 +1838,36 @@ Change the state of this item." "Face used for pushable variable tags." :group 'custom-faces) +(defcustom custom-variable-default-form 'edit + "Default form of displaying variable values." + :type '(choice (const edit) + (const lisp)) + :group 'custom-buffer + :version "20.3") + (define-widget 'custom-variable 'custom "Customize variable." - :format "%l%v%m%h%a" + :format "%v" :help-echo "Set or reset this variable." :documentation-property 'variable-documentation + :custom-category 'option :custom-state nil :custom-menu 'custom-variable-menu-create - :custom-form 'edit + :custom-form nil ; defaults to value of `custom-variable-default-form' :value-create 'custom-variable-value-create :action 'custom-variable-action :custom-set 'custom-variable-set :custom-save 'custom-variable-save :custom-reset-current 'custom-redraw :custom-reset-saved 'custom-variable-reset-saved - :custom-reset-factory 'custom-variable-reset-factory) + :custom-reset-standard 'custom-variable-reset-standard) (defun custom-variable-type (symbol) "Return a widget suitable for editing the value of SYMBOL. If SYMBOL has a `custom-type' property, use that. Otherwise, look up symbol in `custom-guess-type-alist'." (let* ((type (or (get symbol 'custom-type) - (and (not (get symbol 'factory-value)) + (and (not (get symbol 'standard-value)) (custom-guess-type symbol)) 'sexp)) (options (get symbol 'custom-options)) @@ -1195,6 +1881,8 @@ Otherwise, look up symbol in `custom-guess-type-alist'." (defun custom-variable-value-create (widget) "Here is where you edit the variables value." (custom-load-widget widget) + (unless (widget-get widget :custom-form) + (widget-put widget :custom-form custom-variable-default-form)) (let* ((buttons (widget-get widget :buttons)) (children (widget-get widget :children)) (form (widget-get widget :custom-form)) @@ -1203,8 +1891,11 @@ 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)) + (prefix (widget-get widget :custom-prefix)) + (last (widget-get widget :custom-last)) (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) @@ -1216,58 +1907,126 @@ Otherwise, look up symbol in `custom-guess-type-alist'." (when (eq state 'unknown) (unless (widget-apply conv :match value) ;; (widget-apply (widget-convert type) :match value) - (setq form 'lisp))) + (setq form 'mismatch))) ;; Now we can create the child widget. - (cond ((eq state 'hidden) + (cond ((eq custom-buffer-style 'tree) + (insert prefix (if last " `--- " " |--- ")) + (push (widget-create-child-and-convert + widget 'custom-browse-variable-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((eq state 'hidden) ;; Indicate hidden value. (push (widget-create-child-and-convert widget 'item - :format "%{%t%}: ..." - :sample-face 'custom-variable-sample-face + :format "%{%t%}: " + :sample-face 'custom-variable-tag-face :tag tag :parent widget) - children)) - ((eq form 'lisp) + buttons) + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Show the value of this option." + :action 'custom-toggle-parent + nil) + buttons)) + ((memq form '(lisp mismatch)) ;; In lisp mode edit the saved value when possible. (let* ((value (cond ((get symbol 'saved-value) (car (get symbol 'saved-value))) - ((get symbol 'factory-value) - (car (get symbol 'factory-value))) + ((get symbol 'standard-value) + (car (get symbol 'standard-value))) ((default-boundp symbol) - (custom-quote (default-value symbol))) + (custom-quote (funcall get symbol))) (t (custom-quote (widget-get conv :value)))))) + (insert (symbol-name symbol) ": ") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide the value of this option." + :action 'custom-toggle-parent + t) + buttons) + (insert " ") (push (widget-create-child-and-convert widget 'sexp :button-face 'custom-variable-button-face + :format "%v" :tag (symbol-name symbol) :parent widget :value value) children))) (t ;; Edit mode. - (push (widget-create-child-and-convert - widget type - :tag tag - :button-face 'custom-variable-button-face - :sample-face 'custom-variable-sample-face - :value value) - children))) - ;; Now update the state. - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (if (eq state 'hidden) - (widget-put widget :custom-state state) - (custom-variable-state-set widget)) - (widget-put widget :custom-form form) - (widget-put widget :buttons buttons) - (widget-put widget :children children))) + (let* ((format (widget-get type :format)) + tag-format value-format) + (unless (string-match ":" format) + (error "Bad format")) + (setq tag-format (substring format 0 (match-end 0))) + (setq value-format (substring format (match-end 0))) + (push (widget-create-child-and-convert + widget 'item + :format tag-format + :action 'custom-tag-action + :help-echo "Change value of this option." + :mouse-down-action 'custom-tag-mouse-down-action + :button-face 'custom-variable-button-face + :sample-face 'custom-variable-tag-face + tag) + buttons) + (insert " ") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide the value of this option." + :action 'custom-toggle-parent + t) + buttons) + (push (widget-create-child-and-convert + widget type + :format value-format + :value value) + children)))) + (unless (eq custom-buffer-style 'tree) + ;; Now update the state. + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (if (eq state 'hidden) + (widget-put widget :custom-state state) + (custom-variable-state-set widget)) + ;; Create the magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update properties. + (widget-put widget :custom-form form) + (widget-put widget :buttons buttons) + (widget-put widget :children children) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; See also. + (unless (eq state 'hidden) + (when (eq (widget-get widget :custom-level) 1) + (custom-add-parent-links widget)) + (custom-add-see-also widget))))) + +(defun custom-tag-action (widget &rest args) + "Pass :action to first child of WIDGET's parent." + (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children)) + :action args)) + +(defun custom-tag-mouse-down-action (widget &rest args) + "Pass :mouse-down-action to first child of WIDGET's parent." + (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children)) + :mouse-down-action args)) (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)) @@ -1282,39 +2041,64 @@ Otherwise, look up symbol in `custom-guess-type-alist'." (error nil)) 'saved 'changed)) - ((setq tmp (get symbol 'factory-value)) + ((setq tmp (get symbol 'standard-value)) (if (condition-case nil (equal value (eval (car tmp))) (error nil)) - 'factory + 'standard 'changed)) (t 'rogue)))) (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)) + '(("Set for Current Session" custom-variable-set + (lambda (widget) + (eq (widget-get widget :custom-state) 'modified))) + ("Save for Future Sessions" 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 changed))))) + ("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 Standard Settings" custom-variable-reset-standard + (lambda (widget) + (and (get (widget-value widget) 'standard-value) + (memq (widget-get widget :custom-state) + '(modified set changed saved rogue))))) + ("---" ignore ignore) + ("Don't show as Lisp expression" custom-variable-edit + (lambda (widget) + (eq (widget-get widget :custom-form) 'lisp))) + ("Show initial Lisp expression" custom-variable-edit-lisp + (lambda (widget) + (eq (widget-get widget :custom-form) 'edit)))) "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) + (unless (eq (widget-get widget :custom-state) 'modified) + (custom-variable-state-set widget)) + (custom-redraw-magic widget) (let* ((completion-ignore-case t) - (answer (widget-choose (custom-unlispify-tag-name - (widget-get widget :value)) - custom-variable-menu + (answer (widget-choose (concat "Operation on " + (custom-unlispify-tag-name + (widget-get widget :value))) + (custom-menu-filter custom-variable-menu + widget) event))) (if answer (funcall answer widget))))) @@ -1333,45 +2117,47 @@ 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.")) + (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)))) + ((memq form '(lisp mismatch)) + (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) + "Set and save the 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)) + (set (or (get symbol 'custom-set) 'set-default)) + val) (cond ((eq state 'hidden) - (error "Cannot set hidden variable.")) + (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) + ((memq form '(lisp mismatch)) (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,22 +2165,24 @@ 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) (widget-put widget :custom-state 'unknown) (custom-redraw widget))) -(defun custom-variable-reset-factory (widget) - "Restore the factory setting for the variable being edited by WIDGET." - (let ((symbol (widget-value widget))) - (if (get symbol 'factory-value) - (set-default symbol (eval (car (get symbol 'factory-value)))) - (error "No factory default for %S" symbol)) +(defun custom-variable-reset-standard (widget) + "Restore the standard setting for the variable being edited by WIDGET." + (let* ((symbol (widget-value widget)) + (set (or (get symbol 'custom-set) 'set-default))) + (if (get symbol 'standard-value) + (funcall set symbol (eval (car (get symbol 'standard-value)))) + (error "No standard setting known for %S" symbol)) (put symbol 'customized-value nil) (when (get symbol 'saved-value) (put symbol 'saved-value nil) @@ -1443,10 +2231,10 @@ The X11 Window System.") :sibling-args (:help-echo "\ OS/2 Presentation Manager.") pm) - (const :format "Win32 " + (const :format "W32 " :sibling-args (:help-echo "\ -Windows NT/95/97.") - win32) +Windows NT/9X.") + w32) (const :format "DOS " :sibling-args (:help-echo "\ Plain MS-DOS.") @@ -1495,44 +2283,31 @@ Match frames with dark backgrounds.") "Face used for face tags." :group 'custom-faces) +(defcustom custom-face-default-form 'selected + "Default form of displaying face definition." + :type '(choice (const all) + (const selected) + (const lisp)) + :group 'custom-buffer + :version "20.3") + (define-widget 'custom-face 'custom "Customize face." - :format "%l%{%t%}: %s%m%h%a%v" - :format-handler 'custom-face-format-handler :sample-face 'custom-face-tag-face :help-echo "Set or reset this face." :documentation-property '(lambda (face) (face-doc-string face)) :value-create 'custom-face-value-create :action 'custom-face-action - :custom-form 'selected + :custom-category 'face + :custom-form nil ; defaults to value of `custom-face-default-form' :custom-set 'custom-face-set :custom-save 'custom-face-save :custom-reset-current 'custom-redraw :custom-reset-saved 'custom-face-reset-saved - :custom-reset-factory 'custom-face-reset-factory + :custom-reset-standard 'custom-face-reset-standard :custom-menu 'custom-face-menu-create) -(defun custom-face-format-handler (widget escape) - ;; We recognize extra escape sequences. - (let (child - (symbol (widget-get widget :value))) - (cond ((eq escape ?s) - (and (string-match "XEmacs" emacs-version) - ;; XEmacs cannot display initialized faces. - (not (custom-facep symbol)) - (copy-face 'custom-face-empty symbol)) - (setq child (widget-create-child-and-convert - widget 'item - :format "(%{%t%})\n" - :sample-face symbol - :tag "sample"))) - (t - (custom-format-handler widget escape))) - (when child - (widget-put widget - :buttons (cons child (widget-get widget :buttons)))))) - (define-widget 'custom-face-all 'editable-list "An editable list of display specifications and attributes." :entry-format "%i %d %v" @@ -1550,9 +2325,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 (face-spec-set-match-display value (selected-frame)))) (define-widget 'custom-face-selected 'group "Edit the attributes of the selected display in a face specification." @@ -1568,49 +2341,128 @@ Match frames with dark backgrounds.") "Converted version of the `custom-face-selected' widget.") (defun custom-face-value-create (widget) - ;; Create a list of the display specifications. - (unless (eq (preceding-char) ?\n) - (insert "\n")) - (when (not (eq (widget-get widget :custom-state) 'hidden)) - (message "Creating face editor...") - (custom-load-widget widget) - (let* ((symbol (widget-value widget)) - (spec (or (get symbol 'saved-face) - (get symbol 'factory-face) - ;; Attempt to construct it. - (list (list t (custom-face-attributes-get - symbol (selected-frame)))))) - (form (widget-get widget :custom-form)) - (indent (widget-get widget :indent)) - (edit (widget-create-child-and-convert - widget - (cond ((and (eq form 'selected) - (widget-apply custom-face-selected :match spec)) - (when indent (insert-char ?\ indent)) - 'custom-face-selected) - ((and (not (eq form 'lisp)) - (widget-apply custom-face-all :match spec)) - 'custom-face-all) - (t - (when indent (insert-char ?\ indent)) - 'sexp)) - :value spec))) - (custom-face-state-set widget) - (widget-put widget :children (list edit))) - (message "Creating face editor...done"))) + "Create a list of the display specifications for WIDGET." + (let ((buttons (widget-get widget :buttons)) + (symbol (widget-get widget :value)) + (tag (widget-get widget :tag)) + (state (widget-get widget :custom-state)) + (begin (point)) + (is-last (widget-get widget :custom-last)) + (prefix (widget-get widget :custom-prefix))) + (unless tag + (setq tag (prin1-to-string symbol))) + (cond ((eq custom-buffer-style 'tree) + (insert prefix (if is-last " `--- " " |--- ")) + (push (widget-create-child-and-convert + widget 'custom-browse-face-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + (t + ;; Create tag. + (insert tag) + (if (eq custom-buffer-style 'face) + (insert " ") + (widget-specify-sample widget begin (point)) + (insert ": ")) + ;; Sample. + (and (string-match "XEmacs" emacs-version) + ;; XEmacs cannot display uninitialized faces. + (not (custom-facep symbol)) + (copy-face 'custom-face-empty symbol)) + (push (widget-create-child-and-convert widget 'item + :format "(%{%t%})" + :sample-face symbol + :tag "sample") + buttons) + ;; Visibility. + (insert " ") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide or show this face." + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons) + ;; Magic. + (insert "\n") + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; See also. + (unless (eq state 'hidden) + (when (eq (widget-get widget :custom-level) 1) + (custom-add-parent-links widget)) + (custom-add-see-also widget)) + ;; Editor. + (unless (eq (preceding-char) ?\n) + (insert "\n")) + (unless (eq state 'hidden) + (message "Creating face editor...") + (custom-load-widget widget) + (unless (widget-get widget :custom-form) + (widget-put widget :custom-form custom-face-default-form)) + (let* ((symbol (widget-value widget)) + (spec (or (get symbol 'saved-face) + (get symbol 'face-defface-spec) + ;; Attempt to construct it. + (list (list t (custom-face-attributes-get + symbol (selected-frame)))))) + (form (widget-get widget :custom-form)) + (indent (widget-get widget :indent)) + edit) + ;; If the user has changed this face in some other way, + ;; edit it as the user has specified it. + (if (not (face-spec-match-p symbol spec (selected-frame))) + (setq spec (list (list t (face-attr-construct symbol (selected-frame)))))) + (setq edit (widget-create-child-and-convert + widget + (cond ((and (eq form 'selected) + (widget-apply custom-face-selected + :match spec)) + (when indent (insert-char ?\ indent)) + 'custom-face-selected) + ((and (not (eq form 'lisp)) + (widget-apply custom-face-all + :match spec)) + 'custom-face-all) + (t + (when indent (insert-char ?\ indent)) + 'sexp)) + :value spec)) + (custom-face-state-set widget) + (widget-put widget :children (list edit))) + (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)) + '(("Set for Current Session" custom-face-set) + ("Save for Future Sessions" custom-face-save-command) + ("Reset to Saved" custom-face-reset-saved + (lambda (widget) + (get (widget-value widget) 'saved-face))) + ("Reset to Standard Setting" custom-face-reset-standard + (lambda (widget) + (get (widget-value widget) 'face-defface-spec))) + ("---" ignore ignore) + ("Show all display specs" custom-face-edit-all + (lambda (widget) + (not (eq (widget-get widget :custom-form) 'all)))) + ("Just current attributes" custom-face-edit-selected + (lambda (widget) + (not (eq (widget-get widget :custom-form) 'selected)))) + ("Show as Lisp expression" custom-face-edit-lisp + (lambda (widget) + (not (eq (widget-get widget :custom-form) 'lisp))))) "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." @@ -1637,8 +2489,8 @@ when the action is chosen.") 'set) ((get symbol 'saved-face) 'saved) - ((get symbol 'factory-face) - 'factory) + ((get symbol 'face-defface-spec) + 'standard) (t 'rogue))))) @@ -1646,13 +2498,14 @@ 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))) + (answer (widget-choose (concat "Operation on " + (custom-unlispify-tag-name symbol)) + (custom-menu-filter custom-face-menu + widget) + event))) (if answer (funcall answer widget))))) @@ -1662,18 +2515,24 @@ Optional EVENT is the location for the menu." (child (car (widget-get widget :children))) (value (widget-value child))) (put symbol 'customized-face value) - (custom-face-display-set symbol value) + (face-spec-set symbol value) (custom-face-state-set widget) (custom-redraw-magic widget))) +(defun custom-face-save-command (widget) + "Save in `.emacs' the face attributes in WIDGET." + (custom-face-save widget) + (custom-save-all)) + (defun custom-face-save (widget) - "Make the face attributes in WIDGET default." + "Prepare for saving WIDGET's face attributes, but don't write `.emacs'." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) (value (widget-value child))) - (custom-face-display-set symbol value) + (face-spec-set symbol value) (put symbol 'saved-face value) (put symbol 'customized-face nil) + (custom-save-all) (custom-face-state-set widget) (custom-redraw-magic widget))) @@ -1685,23 +2544,23 @@ Optional EVENT is the location for the menu." (unless value (error "No saved value for this face")) (put symbol 'customized-face nil) - (custom-face-display-set symbol value) + (face-spec-set symbol value) (widget-value-set child value) (custom-face-state-set widget) (custom-redraw-magic widget))) -(defun custom-face-reset-factory (widget) - "Restore WIDGET to the face's factory settings." +(defun custom-face-reset-standard (widget) + "Restore WIDGET to the face's standard settings." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) - (value (get symbol 'factory-face))) + (value (get symbol 'face-defface-spec))) (unless value - (error "No factory default for this face")) + (error "No standard setting for this face")) (put symbol 'customized-face nil) (when (get symbol 'saved-face) (put symbol 'saved-face nil) (custom-save-all)) - (custom-face-display-set symbol value) + (face-spec-set symbol value) (widget-value-set child value) (custom-face-state-set widget) (custom-redraw-magic widget))) @@ -1710,23 +2569,25 @@ Optional EVENT is the location for the menu." (define-widget 'face 'default "Select and customize a face." - :convert-widget 'widget-item-convert-widget - :format "%[%t%]: %v" + :convert-widget 'widget-value-convert-widget + :button-prefix 'widget-push-button-prefix + :button-suffix 'widget-push-button-suffix + :format "%t: %[select face%] %v" :tag "Face" :value 'default :value-create 'widget-face-value-create :value-delete 'widget-face-value-delete - :value-get 'widget-item-value-get - :validate 'widget-editable-list-validate + :value-get 'widget-value-value-get + :validate 'widget-children-validate :action 'widget-face-action :match '(lambda (widget value) (symbolp value))) (defun widget-face-value-create (widget) ;; Create a `custom-face' child. (let* ((symbol (widget-value widget)) + (custom-buffer-style 'face) (child (widget-create-child-and-convert widget 'custom-face - :format "%t %s%m%h%v" :custom-level nil :value symbol))) (custom-magic-reset child) @@ -1759,6 +2620,13 @@ Optional EVENT is the location for the menu." (define-widget 'hook 'list "A emacs lisp hook" + :value-to-internal (lambda (widget value) + (if (and value (symbolp value)) + (list value) + value)) + :match (lambda (widget value) + (or (symbolp value) + (widget-group-match widget value))) :convert-widget 'custom-hook-convert-widget :tag "Hook") @@ -1778,9 +2646,19 @@ Optional EVENT is the location for the menu." (widget-put widget :args args) widget)) +;;; The `custom-group-link' Widget. + +(define-widget 'custom-group-link 'link + "Show parent in other window when activated." + :help-echo "Create customization buffer for this group." + :action 'custom-group-link-action) + +(defun custom-group-link-action (widget &rest ignore) + (customize-group (widget-value widget))) + ;;; The `custom-group' Widget. -(defcustom custom-group-tag-faces '(custom-group-tag-face-1) +(defcustom custom-group-tag-faces nil ;; In XEmacs, this ought to play games with font size. "Face used for group tags. The first member is used for level 1 groups, the second for level 2, @@ -1810,17 +2688,18 @@ and so forth. The remaining group tags are shown with (define-widget 'custom-group 'custom "Customize group." - :format "%l%{%t%}:%L\n%m%h%a%v" + :format "%v" :sample-face-get 'custom-group-sample-face-get :documentation-property 'group-documentation :help-echo "Set or reset all members of this group." :value-create 'custom-group-value-create :action 'custom-group-action + :custom-category 'group :custom-set 'custom-group-set :custom-save 'custom-group-save :custom-reset-current 'custom-group-reset-current :custom-reset-saved 'custom-group-reset-saved - :custom-reset-factory 'custom-group-reset-factory + :custom-reset-standard 'custom-group-reset-standard :custom-menu 'custom-group-menu-create) (defun custom-group-sample-face-get (widget) @@ -1828,64 +2707,282 @@ and so forth. The remaining group tags are shown with (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces) 'custom-group-tag-face)) +(define-widget 'custom-group-visibility 'visibility + "An indicator and manipulator for hidden group contents." + :create 'custom-group-visibility-create) + +(defun custom-group-visibility-create (widget) + (let ((visible (widget-value widget))) + (if visible + (insert "--------"))) + (widget-default-create widget)) + +(defun custom-group-members (symbol groups-only) + "Return SYMBOL's custom group members. +If GROUPS-ONLY non-nil, return only those members that are groups." + (if (not groups-only) + (get symbol 'custom-group) + (let (members) + (dolist (entry (get symbol 'custom-group)) + (when (eq (nth 1 entry) 'custom-group) + (push entry members))) + (nreverse members)))) + (defun custom-group-value-create (widget) - (let ((state (widget-get widget :custom-state))) - (unless (eq state 'hidden) - (message "Creating group...") - (custom-load-widget widget) - (let* ((level (widget-get widget :custom-level)) - (symbol (widget-value widget)) - (members (get symbol 'custom-group)) - (prefixes (widget-get widget :custom-prefixes)) - (custom-prefix-list (custom-prefix-add symbol prefixes)) - (length (length members)) - (count 0) - (children (mapcar (lambda (entry) - (widget-insert "\n") - (message "Creating group members... %2d%%" - (/ (* 100.0 count) length)) - (setq count (1+ count)) - (prog1 - (widget-create-child-and-convert - widget (nth 1 entry) - :group widget - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :custom-prefixes custom-prefix-list - :custom-level (1+ level) - :value (nth 0 entry)) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")))) - members))) - (message "Creating group magic...") - (mapcar 'custom-magic-reset children) - (message "Creating group state...") - (widget-put widget :children children) - (custom-group-state-update widget) - (message "Creating group... done"))))) + "Insert a customize group for WIDGET in the current buffer." + (let* ((state (widget-get widget :custom-state)) + (level (widget-get widget :custom-level)) + ;; (indent (widget-get widget :indent)) + (prefix (widget-get widget :custom-prefix)) + (buttons (widget-get widget :buttons)) + (tag (widget-get widget :tag)) + (symbol (widget-value widget)) + (members (custom-group-members symbol + (and (eq custom-buffer-style 'tree) + custom-browse-only-groups)))) + (cond ((and (eq custom-buffer-style 'tree) + (eq state 'hidden) + (or members (custom-unloaded-widget-p widget))) + (custom-browse-insert-prefix prefix) + (push (widget-create-child-and-convert + widget 'custom-browse-visibility + ;; :tag-glyph "plus" + :tag "+") + buttons) + (insert "-- ") + ;; (widget-glyph-insert nil "-- " "horizontal") + (push (widget-create-child-and-convert + widget 'custom-browse-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((and (eq custom-buffer-style 'tree) + (zerop (length members))) + (custom-browse-insert-prefix prefix) + (insert "[ ]-- ") + ;; (widget-glyph-insert nil "[ ]" "empty") + ;; (widget-glyph-insert nil "-- " "horizontal") + (push (widget-create-child-and-convert + widget 'custom-browse-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((eq custom-buffer-style 'tree) + (custom-browse-insert-prefix prefix) + (custom-load-widget widget) + (if (zerop (length members)) + (progn + (custom-browse-insert-prefix prefix) + (insert "[ ]-- ") + ;; (widget-glyph-insert nil "[ ]" "empty") + ;; (widget-glyph-insert nil "-- " "horizontal") + (push (widget-create-child-and-convert + widget 'custom-browse-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + (push (widget-create-child-and-convert + widget 'custom-browse-visibility + ;; :tag-glyph "minus" + :tag "-") + buttons) + (insert "-\\ ") + ;; (widget-glyph-insert nil "-\\ " "top") + (push (widget-create-child-and-convert + widget 'custom-browse-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons) + (message "Creating group...") + (let* ((members (custom-sort-items members + custom-browse-sort-alphabetically + custom-browse-order-groups)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) + (extra-prefix (if (widget-get widget :custom-last) + " " + " | ")) + (prefix (concat prefix extra-prefix)) + children entry) + (while members + (setq entry (car members) + members (cdr members)) + (push (widget-create-child-and-convert + widget (nth 1 entry) + :group widget + :tag (custom-unlispify-tag-name (nth 0 entry)) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :custom-last (null members) + :value (nth 0 entry) + :custom-prefix prefix) + children)) + (widget-put widget :children (reverse children))) + (message "Creating group...done"))) + ;; Nested style. + ((eq state 'hidden) + ;; Create level indicator. + (unless (eq custom-buffer-style 'links) + (insert-char ?\ (* custom-buffer-indent (1- level))) + (insert "-- ")) + ;; Create tag. + (let ((begin (point))) + (insert tag) + (widget-specify-sample widget begin (point))) + (insert " group: ") + ;; Create link/visibility indicator. + (if (eq custom-buffer-style 'links) + (push (widget-create-child-and-convert + widget 'custom-group-link + :tag "Go to Group" + symbol) + buttons) + (push (widget-create-child-and-convert + widget 'custom-group-visibility + :help-echo "Show members of this group." + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons)) + (insert " \n") + ;; Create magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (if (and (eq custom-buffer-style 'links) (> level 1)) + (widget-put widget :documentation-indent 0)) + (widget-default-format-handler widget ?h)) + ;; Nested style. + (t ;Visible. + ;; Add parent groups references above the group. + (if t ;;; This should test that the buffer + ;;; was made to display a group. + (when (eq level 1) + (if (custom-add-parent-links widget + "Go to parent group:") + (insert "\n")))) + ;; Create level indicator. + (insert-char ?\ (* custom-buffer-indent (1- level))) + (insert "/- ") + ;; Create tag. + (let ((start (point))) + (insert tag) + (widget-specify-sample widget start (point))) + (insert " group: ") + ;; Create visibility indicator. + (unless (eq custom-buffer-style 'links) + (insert "--------") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide members of this group." + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons) + (insert " ")) + ;; Create more dashes. + ;; Use 76 instead of 75 to compensate for the temporary "<" + ;; added by `widget-insert'. + (insert-char ?- (- 76 (current-column) + (* custom-buffer-indent level))) + (insert "\\\n") + ;; Create magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic + :indent 0 + nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; Parent groups. + (if nil ;;; This should test that the buffer + ;;; was not made to display a group. + (when (eq level 1) + (insert-char ?\ custom-buffer-indent) + (custom-add-parent-links widget))) + (custom-add-see-also widget + (make-string (* custom-buffer-indent level) + ?\ )) + ;; Members. + (message "Creating group...") + (custom-load-widget widget) + (let* ((members (custom-sort-items members + custom-buffer-sort-alphabetically + custom-buffer-order-groups)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) + (length (length members)) + (count 0) + (children (mapcar (lambda (entry) + (widget-insert "\n") + (message "\ +Creating group members... %2d%%" + (/ (* 100.0 count) length)) + (setq count (1+ count)) + (prog1 + (widget-create-child-and-convert + widget (nth 1 entry) + :group widget + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :value (nth 0 entry)) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")))) + members))) + (message "Creating group magic...") + (mapcar 'custom-magic-reset children) + (message "Creating group state...") + (widget-put widget :children children) + (custom-group-state-update widget) + (message "Creating group... done")) + ;; End line + (insert "\n") + (insert-char ?\ (* custom-buffer-indent (1- level))) + (insert "\\- " (widget-get widget :tag) " group end ") + (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level))) + (insert "/\n"))))) (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)) + '(("Set for Current Session" custom-group-set + (lambda (widget) + (eq (widget-get widget :custom-state) 'modified))) + ("Save for Future Sessions" custom-group-save + (lambda (widget) + (memq (widget-get widget :custom-state) '(modified set)))) + ("Reset to Current" custom-group-reset-current + (lambda (widget) + (memq (widget-get widget :custom-state) '(modified)))) + ("Reset to Saved" custom-group-reset-saved + (lambda (widget) + (memq (widget-get widget :custom-state) '(modified set)))) + ("Reset to standard setting" custom-group-reset-standard + (lambda (widget) + (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 + (answer (widget-choose (concat "Operation on " + (custom-unlispify-tag-name + (widget-get widget :value))) + (custom-menu-filter custom-group-menu + widget) event))) (if answer (funcall answer widget))))) @@ -1922,13 +3019,13 @@ Optional EVENT is the location for the menu." (widget-apply child :custom-reset-saved))) children ))) -(defun custom-group-reset-factory (widget) +(defun custom-group-reset-standard (widget) "Reset all modified, set, or saved group members." (let ((children (widget-get widget :children))) (mapcar (lambda (child) (when (memq (widget-get child :custom-state) '(modified set saved)) - (widget-apply child :custom-reset-factory))) + (widget-apply child :custom-reset-standard))) children ))) (defun custom-group-state-update (widget) @@ -1939,7 +3036,7 @@ Optional EVENT is the location for the menu." (widget-get child :custom-state)) children)) (magics custom-magic-alist) - (found 'factory)) + (found 'standard)) (while magics (let ((magic (car (car magics)))) (if (and (not (eq magic 'hidden)) @@ -1951,18 +3048,28 @@ Optional EVENT is the location for the menu." (custom-magic-reset widget)) ;;; The `custom-save-all' Function. - -(defcustom custom-file "~/.emacs" +;;;###autoload +(defcustom custom-file nil "File used for storing customization information. -If you change this from the default \"~/.emacs\" you need to -explicitly load that file for the settings to take effect." - :type 'file +The default is nil, which means to use your init file +as specified by `user-init-file'. If you specify some other file, +you need to explicitly load that file for the settings to take effect." + :type '(choice (const :tag "Your Emacs init file" nil) file) :group 'customize) +(defun custom-file () + "Return the file name for saving customizations." + (setq custom-file + (or custom-file + user-init-file + (read-file-name "File for customizations: " + "~/" nil nil ".emacs")))) + (defun custom-save-delete (symbol) - "Delete the call to SYMBOL form `custom-file'. + "Delete the call to SYMBOL from `custom-file'. Leave point at the location of the call, or after the last expression." - (set-buffer (find-file-noselect custom-file)) + (let ((default-major-mode)) + (set-buffer (find-file-noselect (custom-file)))) (goto-char (point-min)) (catch 'found (while t @@ -1986,17 +3093,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 'standard-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"))))) @@ -2014,7 +3130,7 @@ Leave point at the location of the call, or after the last expression." (when value (princ "\n '(default ") (prin1 value) - (if (or (get 'default 'factory-face) + (if (or (get 'default 'face-defface-spec) (and (not (custom-facep 'default)) (not (get 'default 'force-face)))) (princ ")") @@ -2028,7 +3144,7 @@ Leave point at the location of the call, or after the last expression." (princ symbol) (princ " ") (prin1 value) - (if (or (get symbol 'factory-face) + (if (or (get symbol 'face-defface-spec) (and (not (custom-facep symbol)) (not (get symbol 'force-face)))) (princ ")") @@ -2037,59 +3153,46 @@ Leave point at the location of the call, or after the last expression." (unless (looking-at "\n") (princ "\n"))))) +;;;###autoload +(defun customize-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) - (custom-save-faces) - (save-excursion - (set-buffer (find-file-noselect custom-file)) - (save-buffer))) + (let ((inhibit-read-only t)) + (custom-save-variables) + (custom-save-faces) + (save-excursion + (let ((default-major-mode nil)) + (set-buffer (find-file-noselect (custom-file)))) + (save-buffer)))) ;;; The Customize Menu. ;;; Menu support -(unless (string-match "XEmacs" emacs-version) - (defconst custom-help-menu '("Customize" - ["Update menu..." custom-menu-update t] - ["Group..." customize t] - ["Variable..." customize-variable t] - ["Face..." customize-face t] - ["Saved..." customize-customized t] - ["Apropos..." customize-apropos t]) - ;; This menu should be identical to the one defined in `menu-bar.el'. - "Customize menu") - - (defun custom-menu-reset () - "Reset customize menu." - (remove-hook 'custom-define-hook 'custom-menu-reset) - (define-key global-map [menu-bar help-menu customize-menu] - (cons (car custom-help-menu) - (easy-menu-create-keymaps (car custom-help-menu) - (cdr custom-help-menu))))) - - (defun custom-menu-update (event) - "Update customize menu." - (interactive "e") - (add-hook 'custom-define-hook 'custom-menu-reset) - (let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs)) - (menu `(,(car custom-help-menu) - ,emacs - ,@(cdr (cdr custom-help-menu))))) - (let ((map (easy-menu-create-keymaps (car menu) (cdr menu)))) - (define-key global-map [menu-bar help-menu customize-menu] - (cons (car menu) map))))) - - (defcustom custom-menu-nesting 2 - "Maximum nesting in custom menus." - :type 'integer - :group 'customize)) +(defcustom custom-menu-nesting 2 + "Maximum nesting in custom menus." + :type 'integer + :group 'custom-menu) (defun custom-face-menu-create (widget symbol) "Ignoring WIDGET, create a menu entry for customization face SYMBOL." (vector (custom-unlispify-menu-entry symbol) - `(custom-buffer-create '((,symbol custom-face))) + `(customize-face ',symbol) t)) (defun custom-variable-menu-create (widget symbol) @@ -2100,15 +3203,14 @@ Leave point at the location of the call, or after the last expression." (if (and type (widget-get type :custom-menu)) (widget-apply type :custom-menu symbol) (vector (custom-unlispify-menu-entry symbol) - `(custom-buffer-create '((,symbol custom-variable))) + `(customize-variable ',symbol) t)))) ;; Add checkboxes to boolean variable entries. (widget-put (get 'boolean 'widget-type) :custom-menu (lambda (widget symbol) (vector (custom-unlispify-menu-entry symbol) - `(custom-buffer-create - '((,symbol custom-variable))) + `(customize-variable ',symbol) ':style 'toggle ':selected symbol))) @@ -2131,13 +3233,16 @@ Leave point at the location of the call, or after the last expression." "Create menu for customization group SYMBOL. The menu is in a format applicable to `easy-menu-define'." (let* ((item (vector (custom-unlispify-menu-entry symbol) - `(custom-buffer-create '((,symbol custom-group))) + `(customize-group ',symbol) t))) (if (and (or (not (boundp 'custom-menu-nesting)) (>= custom-menu-nesting 0)) (< (length (get symbol 'custom-group)) widget-menu-max-size)) (let ((custom-prefix-list (custom-prefix-add symbol - custom-prefix-list))) + custom-prefix-list)) + (members (custom-sort-items (get symbol 'custom-group) + custom-menu-sort-alphabetically + custom-menu-order-groups))) (custom-load-symbol symbol) `(,(custom-unlispify-menu-entry symbol t) ,item @@ -2147,7 +3252,7 @@ The menu is in a format applicable to `easy-menu-define'." (nth 1 entry) (list (nth 1 entry))) :custom-menu (nth 0 entry))) - (get symbol 'custom-group)))) + members))) item))) ;;;###autoload @@ -2170,32 +3275,60 @@ The format is suitable for use with `easy-menu-define'." (defvar custom-mode-map nil "Keymap for `custom-mode'.") - + (unless custom-mode-map (setq custom-mode-map (make-sparse-keymap)) (set-keymap-parent custom-mode-map widget-keymap) - (define-key custom-mode-map "q" 'bury-buffer)) - -(easy-menu-define custom-mode-customize-menu - custom-mode-map - "Menu used in customization buffers." - (customize-menu-create 'customize)) - -(easy-menu-define custom-mode-menu + (suppress-keymap custom-mode-map) + (define-key custom-mode-map " " 'scroll-up) + (define-key custom-mode-map "\177" 'scroll-down) + (define-key custom-mode-map "q" 'bury-buffer) + (define-key custom-mode-map "u" 'Custom-goto-parent) + (define-key custom-mode-map "n" 'widget-forward) + (define-key custom-mode-map "p" 'widget-backward) + (define-key custom-mode-map [mouse-1] 'Custom-move-and-invoke)) + +(defun Custom-move-and-invoke (event) + "Move to where you click, and if it is an active field, invoke it." + (interactive "e") + (mouse-set-point event) + (if (widget-event-point event) + (let* ((pos (widget-event-point event)) + (button (get-char-property pos 'button))) + (if button + (widget-button-click event))))) + +(easy-menu-define Custom-mode-menu custom-mode-map "Menu used in customization buffers." `("Custom" - ["Set" custom-set t] - ["Save" custom-save t] - ["Reset to Current" custom-reset-current t] - ["Reset to Saved" custom-reset-saved t] - ["Reset to Factory Settings" custom-reset-factory t] + ,(customize-menu-create 'customize) + ["Set" Custom-set t] + ["Save" Custom-save t] + ["Reset to Current" Custom-reset-current t] + ["Reset to Saved" Custom-reset-saved t] + ["Reset to Standard Settings" Custom-reset-standard t] ["Info" (Info-goto-node "(custom)The Customization Buffer") t])) +(defun Custom-goto-parent () + "Go to the parent group listed at the top of this buffer. +If several parents are listed, go to the first of them." + (interactive) + (save-excursion + (goto-char (point-min)) + (if (search-forward "\nGo to parent group: " nil t) + (let* ((button (get-char-property (point) 'button)) + (parent (downcase (widget-get button :tag)))) + (customize-group parent))))) + (defcustom custom-mode-hook nil "Hook called when entering custom-mode." :type 'hook - :group 'customize) + :group 'custom-buffer ) + +(defun custom-state-buffer-message (widget) + (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified) + (message "To install your edits, invoke [State] and choose the Set operation"))) (defun custom-mode () "Major mode for editing customization buffers. @@ -2204,13 +3337,16 @@ The following commands are available: Move to next button or editable field. \\[widget-forward] Move to previous button or editable field. \\[widget-backward] -Activate button under the mouse pointer. \\[widget-button-click] -Activate button under point. \\[widget-button-press] -Set all modifications. \\[custom-set] -Make all modifications default. \\[custom-save] -Reset all modified options. \\[custom-reset-current] -Reset all modified or set options. \\[custom-reset-saved] -Reset all options. \\[custom-reset-factory] +\\\ +Complete content of editable text field. \\[widget-complete] +\\\ +Invoke button under the mouse pointer. \\[Custom-move-and-invoke] +Invoke button under point. \\[widget-button-press] +Set all modifications. \\[Custom-set] +Make all modifications default. \\[Custom-save] +Reset all modified options. \\[Custom-reset-current] +Reset all modified or set options. \\[Custom-reset-saved] +Reset all options. \\[Custom-reset-standard] Entry to this mode calls the value of `custom-mode-hook' if that value is non-nil." @@ -2218,9 +3354,14 @@ if that value is non-nil." (setq major-mode 'custom-mode mode-name "Custom") (use-local-map custom-mode-map) - (easy-menu-add custom-mode-customize-menu) - (easy-menu-add custom-mode-menu) + (easy-menu-add Custom-mode-menu) (make-local-variable 'custom-options) + (make-local-variable 'widget-documentation-face) + (setq widget-documentation-face 'custom-documentation-face) + (make-local-variable 'widget-button-face) + (setq widget-button-face 'custom-button-face) + (make-local-hook 'widget-edit-functions) + (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t) (run-hooks 'custom-mode-hook)) ;;; The End.