X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/6cda144ffe7e8da08b15430072f3b112967d5281..6431f2e619d1ce4cff097a3837f6b9e931f1f61a:/lisp/cus-edit.el diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index c32dba5bbe..bb2f67422e 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1,7 +1,7 @@ ;;; cus-edit.el --- tools for customizing Emacs and Lisp packages ;; -;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005, +;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -166,10 +166,27 @@ "Basic text editing facilities." :group 'emacs) +(defgroup convenience nil + "Convenience features for faster editing." + :group 'emacs) + +(defgroup files nil + "Support for editing files." + :group 'emacs) + +(defgroup wp nil + "Support for editing text files." + :tag "Text" + :group 'emacs) + +(defgroup data nil + "Support for editing binary data files." + :group 'emacs) + (defgroup abbrev nil "Abbreviation handling, typing shortcuts, macros." :tag "Abbreviations" - :group 'editing) + :group 'convenience) (defgroup matching nil "Various sorts of searching and matching." @@ -186,20 +203,20 @@ (defgroup outlines nil "Support for hierarchical outlining." - :group 'editing) + :group 'wp) (defgroup external nil "Interfacing to external utilities." :group 'emacs) +(defgroup comm nil + "Communications, networking, and remote access to files." + :tag "Communication" + :group 'emacs) + (defgroup processes nil "Process, subshell, compilation, and job control support." - :group 'external - :group 'development) - -(defgroup convenience nil - "Convenience features for faster editing." - :group 'emacs) + :group 'external) (defgroup programming nil "Support for programming in other languages." @@ -225,10 +242,6 @@ "Programming tools." :group 'programming) -(defgroup oop nil - "Support for object-oriented programming." - :group 'programming) - (defgroup applications nil "Applications written in Emacs." :group 'emacs) @@ -275,13 +288,8 @@ "Fitting Emacs with its environment." :group 'emacs) -(defgroup comm nil - "Communications, networking, remote access to files." - :tag "Communication" - :group 'environment) - (defgroup hardware nil - "Support for interfacing with exotic hardware." + "Support for interfacing with miscellaneous hardware." :group 'environment) (defgroup terminals nil @@ -306,18 +314,6 @@ "Support for Emacs frames and window systems." :group 'environment) -(defgroup data nil - "Support editing files of data." - :group 'emacs) - -(defgroup files nil - "Support editing files." - :group 'emacs) - -(defgroup wp nil - "Word processing." - :group 'emacs) - (defgroup tex nil "Code related to the TeX formatter." :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) @@ -327,10 +323,6 @@ "Support for multiple fonts." :group 'emacs) -(defgroup hypermedia nil - "Support for links between text or other media types." - :group 'emacs) - (defgroup help nil "Support for on-line help systems." :group 'emacs) @@ -680,10 +672,11 @@ If `last', order groups after non-groups." :group 'custom-browse) ;;;###autoload -(defcustom custom-buffer-sort-alphabetically nil - "If non-nil, sort each customization group alphabetically in Custom buffer." +(defcustom custom-buffer-sort-alphabetically t + "Whether to sort customization groups alphabetically in Custom buffer." :type 'boolean - :group 'custom-buffer) + :group 'custom-buffer + :version "24.1") (defcustom custom-buffer-order-groups 'last "If non-nil, order group members within each customization group. @@ -709,7 +702,7 @@ If `last', order groups after non-groups." (const :tag "none" nil)) :group 'custom-menu) -;;;###autoload (add-hook 'same-window-regexps "\\`\\*Customiz.*\\*\\'") +;;;###autoload (add-hook 'same-window-regexps (purecopy "\\`\\*Customiz.*\\*\\'")) (defun custom-sort-items (items sort-alphabetically order-groups) "Return a sorted copy of ITEMS. @@ -741,31 +734,36 @@ groups after non-groups, if nil do not order groups at all." ;;; Custom Mode Commands. ;; This variable is used by `custom-tool-bar-map', or directly by -;; `custom-buffer-create-internal' if the toolbar is not present and -;; `custom-buffer-verbose-help' is non-nil. +;; `custom-buffer-create-internal' if `custom-buffer-verbose-help' is non-nil. (defvar custom-commands '(("Set for current session" Custom-set t "Apply all settings in this buffer to the current session" - "index") + "index" + "Apply") ("Save for future sessions" Custom-save (or custom-file user-init-file) "Apply all settings in this buffer and save them for future Emacs sessions." - "save") + "save" + "Save") ("Undo edits" Custom-reset-current t "Restore all settings in this buffer to reflect their current values." - "refresh") + "refresh" + "Undo") ("Reset to saved" Custom-reset-saved t "Restore all settings in this buffer to their saved values (if any)." - "undo") + "undo" + "Reset") ("Erase customizations" Custom-reset-standard (or custom-file user-init-file) "Un-customize all settings in this buffer and save them with standard values." - "delete") + "delete" + "Uncustomize") ("Help for Customize" Custom-help t "Get help for using Customize." - "help") - ("Exit" Custom-buffer-done t "Exit Customize." "exit"))) + "help" + "Help") + ("Exit" Custom-buffer-done t "Exit Customize." "exit" "Exit"))) (defun Custom-help () "Read the node on Easy Customization in the Emacs manual." @@ -1137,7 +1135,7 @@ Show the buffer in another window, but don't select it." (unless (eq symbol basevar) (message "`%s' is an alias for `%s'" symbol basevar)))) -(defvar customize-changed-options-previous-release "21.1" +(defvar customize-changed-options-previous-release "23.1" "Version for `customize-changed-options' to refer back to by default.") ;; Packages will update this variable, so make it available. @@ -1383,42 +1381,52 @@ suggest to customize that face, if it's customizable." (custom-buffer-create (custom-sort-items found t nil) "*Customize Saved*")))) +(declare-function apropos-parse-pattern "apropos" (pattern)) + ;;;###autoload -(defun customize-apropos (regexp &optional all) - "Customize all loaded options, faces and groups matching REGEXP. -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 variables +(defun customize-apropos (pattern &optional type) + "Customize all loaded options, faces and groups matching PATTERN. +PATTERN can be a word, a list of words (separated by spaces), +or a regexp (using some regexp special characters). If it is a word, +search for matches for that word as a substring. If it is a list of words, +search for matches for any two (or more) of those words. + +If TYPE is `options', include only options. +If TYPE is `faces', include only faces. +If TYPE is `groups', include only groups. +If TYPE is t (interactively, with prefix arg), include variables that are not customizable options, as well as faces and groups \(but we recommend using `apropos-variable' instead)." - (interactive "sCustomize (regexp): \nP") - (let ((found nil)) - (mapatoms (lambda (symbol) - (when (string-match regexp (symbol-name 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) - (eq (indirect-variable symbol) symbol) - (or (get symbol 'saved-value) - (custom-variable-p symbol) - (and (not (memq all '(nil options))) - (get symbol 'variable-documentation)))) - (push (list symbol 'custom-variable) found))))) + (interactive (list (apropos-read-pattern "symbol") current-prefix-arg)) + (require 'apropos) + (apropos-parse-pattern pattern) + (let (found tests) + (mapatoms + `(lambda (symbol) + (when (string-match apropos-regexp (symbol-name symbol)) + ,(if (not (memq type '(faces options))) + '(if (get symbol 'custom-group) + (push (list symbol 'custom-group) found))) + ,(if (not (memq type '(options groups))) + '(if (custom-facep symbol) + (push (list symbol 'custom-face) found))) + ,(if (not (memq type '(groups faces))) + `(if (and (boundp symbol) + (eq (indirect-variable symbol) symbol) + (or (get symbol 'saved-value) + (custom-variable-p symbol) + ,(if (not (memq type '(nil options))) + '(get symbol 'variable-documentation)))) + (push (list symbol 'custom-variable) found)))))) (if (not found) (error "No %s matching %s" - (if (eq all t) - "items" - (format "customizable %s" - (if (memq all '(options faces groups)) - (symbol-name all) - "items"))) - regexp) + (if (eq type t) + "items" + (format "customizable %s" + (if (memq type '(options faces groups)) + (symbol-name type) + "items"))) + pattern) (custom-buffer-create (custom-sort-items found t custom-buffer-order-groups) "*Customize Apropos*")))) @@ -1541,6 +1549,12 @@ This button will have a menu with all three reset operations." (defvar custom-button-pressed nil "Face used for pressed buttons in customization buffers.") +(defcustom custom-search-field t + "If non-nil, show a search field in Custom buffers." + :type 'boolean + :version "24.1" + :group 'custom-buffer) + (defcustom custom-raised-buttons (not (equal (face-valid-attribute-values :box) '(("unspecified" . unspecified)))) "If non-nil, indicate active buttons in a `raised-button' style. @@ -1564,14 +1578,9 @@ Otherwise use brackets." (let ((init-file (or custom-file user-init-file))) ;; Insert verbose help at the top of the custom buffer. (when custom-buffer-verbose-help - (widget-insert "Editing a setting changes only the text in this buffer." - (if init-file - " -To apply your changes, use the Save or Set buttons. -Saving a change normally works by editing your init file." - " -Currently, these settings cannot be saved for future Emacs sessions, -possibly because you started Emacs with `-q'.") + (widget-insert (if init-file + "To apply changes, use the Save or Set buttons." + "Custom settings cannot be saved; maybe you started Emacs with `-q'.") "\nFor details, see ") (widget-create 'custom-manual :tag "Saving Customizations" @@ -1582,37 +1591,60 @@ possibly because you started Emacs with `-q'.") :help-echo "Read the Emacs manual." "(emacs)Top") (widget-insert ".")) - ;; Insert custom command buttons if the toolbar is not in use. - (widget-insert "\n") - ;; tool-bar is not dumped in builds without x. - (when (not (and (bound-and-true-p tool-bar-mode) (display-graphic-p))) - (if custom-buffer-verbose-help - (widget-insert "\n - Operate on all settings in this buffer that are not marked HIDDEN:\n")) - (let ((button (lambda (tag action active help icon) - (widget-insert " ") - (if (eval active) - (widget-create 'push-button :tag tag - :help-echo help :action action)))) - (commands custom-commands)) - (apply button (pop commands)) ; Set for current session - (apply button (pop commands)) ; Save for future sessions - (if custom-reset-button-menu - (progn - (widget-insert " ") - (widget-create 'push-button - :tag "Reset buffer" - :help-echo "Show a menu with reset operations." - :mouse-down-action 'ignore - :action 'custom-reset)) - (widget-insert "\n") - (apply button (pop commands)) ; Undo edits - (apply button (pop commands)) ; Reset to saved - (apply button (pop commands)) ; Erase customization - (widget-insert " ") - (pop commands) ; Help (omitted) - (apply button (pop commands))))) ; Exit + + ;; Insert the search field. + (when custom-search-field + (widget-insert "\n") + (let* ((echo "Search for custom items") + (search-widget + (widget-create + 'editable-field + :size 40 :help-echo echo + :action `(lambda (widget &optional event) + (customize-apropos (widget-value widget)))))) + (widget-insert " ") + (widget-create-child-and-convert + search-widget 'push-button + :tag "Search" + :help-echo echo :action + (lambda (widget &optional event) + (customize-apropos (widget-value (widget-get widget :parent))))) + (widget-insert "\n"))) + + ;; The custom command buttons are also in the toolbar, so for a + ;; time they were not inserted in the buffer if the toolbar was in use. + ;; But it can be a little confusing for the buffer layout to + ;; change according to whether or nor the toolbar is on, not to + ;; mention that a custom buffer can in theory be created in a + ;; frame with a toolbar, then later viewed in one without. + ;; So now the buttons are always inserted in the buffer. (Bug#1326) + (if custom-buffer-verbose-help + (widget-insert " + Operate on all settings in this buffer:\n")) + (let ((button (lambda (tag action active help icon label) + (widget-insert " ") + (if (eval active) + (widget-create 'push-button :tag tag + :help-echo help :action action)))) + (commands custom-commands)) + (apply button (pop commands)) ; Set for current session + (apply button (pop commands)) ; Save for future sessions + (if custom-reset-button-menu + (progn + (widget-insert " ") + (widget-create 'push-button + :tag "Reset buffer" + :help-echo "Show a menu with reset operations." + :mouse-down-action 'ignore + :action 'custom-reset)) + (widget-insert "\n") + (apply button (pop commands)) ; Undo edits + (apply button (pop commands)) ; Reset to saved + (apply button (pop commands)) ; Erase customization + (widget-insert " ") + (pop commands) ; Help (omitted) + (apply button (pop commands)))) ; Exit (widget-insert "\n\n")) ;; Now populate the custom buffer. @@ -1810,8 +1842,7 @@ item in another window.\n\n")) (:weight bold :slant italic :underline t))) "Face used when the customize item is invalid." :group 'custom-magic-faces) -;; backward-compatibility alias -(put 'custom-invalid-face 'face-alias 'custom-invalid) +(define-obsolete-face-alias 'custom-invalid-face 'custom-invalid "22.1") (defface custom-rogue '((((class color)) (:foreground "pink" :background "black")) @@ -1819,8 +1850,7 @@ item in another window.\n\n")) (:underline t))) "Face used when the customize item is not defined for customization." :group 'custom-magic-faces) -;; backward-compatibility alias -(put 'custom-rogue-face 'face-alias 'custom-rogue) +(define-obsolete-face-alias 'custom-rogue-face 'custom-rogue "22.1") (defface custom-modified '((((min-colors 88) (class color)) (:foreground "white" :background "blue1")) @@ -1830,8 +1860,7 @@ item in another window.\n\n")) (:slant italic :bold))) "Face used when the customize item has been modified." :group 'custom-magic-faces) -;; backward-compatibility alias -(put 'custom-modified-face 'face-alias 'custom-modified) +(define-obsolete-face-alias 'custom-modified-face 'custom-modified "22.1") (defface custom-set '((((min-colors 88) (class color)) (:foreground "blue1" :background "white")) @@ -1841,8 +1870,7 @@ item in another window.\n\n")) (:slant italic))) "Face used when the customize item has been set." :group 'custom-magic-faces) -;; backward-compatibility alias -(put 'custom-set-face 'face-alias 'custom-set) +(define-obsolete-face-alias 'custom-set-face 'custom-set "22.1") (defface custom-changed '((((min-colors 88) (class color)) (:foreground "white" :background "blue1")) @@ -1852,8 +1880,7 @@ item in another window.\n\n")) (:slant italic))) "Face used when the customize item has been changed." :group 'custom-magic-faces) -;; backward-compatibility alias -(put 'custom-changed-face 'face-alias 'custom-changed) +(define-obsolete-face-alias 'custom-changed-face 'custom-changed "22.1") (defface custom-themed '((((min-colors 88) (class color)) (:foreground "white" :background "blue1")) @@ -1867,8 +1894,7 @@ item in another window.\n\n")) (defface custom-saved '((t (:underline t))) "Face used when the customize item has been saved." :group 'custom-magic-faces) -;; backward-compatibility alias -(put 'custom-saved-face 'face-alias 'custom-saved) +(define-obsolete-face-alias 'custom-saved-face 'custom-saved "22.1") (defconst custom-magic-alist '((nil "#" underline "\ @@ -1991,63 +2017,64 @@ and `face'." (nth 3 entry))) (form (widget-get parent :custom-form)) children) - (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 " ") + (unless (eq state 'hidden) + (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 ": ") + (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)) + (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)))) - (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 ": ") - (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)) - (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 - :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))) + (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 + :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)))) (defun custom-magic-reset (widget) "Redraw the :custom-magic property of WIDGET." @@ -2065,8 +2092,7 @@ and `face'." "Face for custom buffer buttons if `custom-raised-buttons' is non-nil." :version "21.1" :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-button-face 'face-alias 'custom-button) +(define-obsolete-face-alias 'custom-button-face 'custom-button "22.1") (defface custom-button-mouse '((((type x w32 ns) (class color)) @@ -2102,8 +2128,8 @@ and `face'." "Face for pressed custom buttons if `custom-raised-buttons' is non-nil." :version "21.1" :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-button-pressed-face 'face-alias 'custom-button-pressed) +(define-obsolete-face-alias 'custom-button-pressed-face + 'custom-button-pressed "22.1") (defface custom-button-pressed-unraised '((default :inherit custom-button-unraised) @@ -2121,8 +2147,8 @@ and `face'." (defface custom-documentation '((t nil)) "Face used for documentation strings in customization buffers." :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-documentation-face 'face-alias 'custom-documentation) +(define-obsolete-face-alias 'custom-documentation-face + 'custom-documentation "22.1") (defface custom-state '((((class color) (background dark)) @@ -2133,8 +2159,7 @@ and `face'." (t nil)) "Face used for State descriptions in the customize buffer." :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-state-face 'face-alias 'custom-state) +(define-obsolete-face-alias 'custom-state-face 'custom-state "22.1") (defface custom-link '((t :inherit link)) @@ -2189,9 +2214,10 @@ and `face'." (when (and (>= pos from) (<= pos to)) (condition-case nil (progn - (if (> column 0) - (goto-line line) - (goto-line (1+ line))) + (goto-char (point-min)) + (forward-line (if (> column 0) + (1- line) + line)) (move-to-column column)) (error nil))))) @@ -2210,12 +2236,9 @@ and `face'." (defun custom-show (widget value) "Non-nil if WIDGET should be shown with VALUE by default." (let ((show (widget-get widget :custom-show))) - (cond ((null show) - nil) - ((eq t show) - t) - (t - (funcall show widget value))))) + (if (functionp show) + (funcall show widget value) + show))) (defun custom-load-widget (widget) "Load all dependencies for WIDGET." @@ -2293,8 +2316,7 @@ Insert PREFIX first if non-nil." (insert ", ")))) (widget-put widget :buttons buttons)))) -(defun custom-add-parent-links (widget &optional initial-string - doc-initial-string) +(defun custom-add-parent-links (widget &optional initial-string doc-initial-string) "Add \"Parent groups: ...\" to WIDGET if the group has parents. The value is non-nil if any parents were found. If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." @@ -2313,36 +2335,6 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." symbol) buttons) (setq parents (cons symbol parents))))) - (and (null (get name 'custom-links)) ;No links of its own. - (= (length parents) 1) ;A single parent. - (let* ((links (delq nil (mapcar (lambda (w) - (unless (eq (widget-type w) - 'custom-group-link) - w)) - (get (car parents) 'custom-links)))) - (many (> (length links) 2))) - (when links - (let ((pt (point)) - (left-margin (+ left-margin 2))) - (insert "\n" (or doc-initial-string "Group documentation:") " ") - (while links - (push (widget-create-child-and-convert - widget (car links) - :button-face 'custom-link - :mouse-face 'highlight - :pressed-face 'highlight) - buttons) - (setq links (cdr links)) - (cond ((null links) - (insert ".\n")) - ((null (cdr links)) - (if many - (insert ", and ") - (insert " and "))) - (t - (insert ", ")))) - (fill-region-as-paragraph pt (point)) - (delete-to-left-margin (1+ pt) (+ pt 2)))))) (if parents (insert "\n") (delete-region start (point))) @@ -2366,8 +2358,7 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." "Face used for comments on variables or faces." :version "21.1" :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-comment-face 'face-alias 'custom-comment) +(define-obsolete-face-alias 'custom-comment-face 'custom-comment "22.1") ;; like font-lock-comment-face (defface custom-comment-tag @@ -2378,17 +2369,16 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." (((class grayscale) (background dark)) (:foreground "LightGray" :weight bold :slant italic)) (t (:weight bold))) - "Face used for variables or faces comment tags." + "Face used for the comment tag on variables or faces." :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-comment-tag-face 'face-alias 'custom-comment-tag) +(define-obsolete-face-alias 'custom-comment-tag-face 'custom-comment-tag "22.1") (define-widget 'custom-comment 'string "User comment." :tag "Comment" :help-echo "Edit a comment here." - :sample-face 'custom-comment-tag-face - :value-face 'custom-comment-face + :sample-face 'custom-comment-tag + :value-face 'custom-comment :shown nil :create 'custom-comment-create) @@ -2419,8 +2409,6 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." ;;; The `custom-variable' Widget. -;; When this was underlined blue, users confused it with a -;; Mosaic-style hyperlink... (defface custom-variable-tag `((((class color) (background dark)) @@ -2434,14 +2422,14 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." (t (:weight bold))) "Face used for unpushable variable tags." :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-variable-tag-face 'face-alias 'custom-variable-tag) +(define-obsolete-face-alias 'custom-variable-tag-face + 'custom-variable-tag "22.1") (defface custom-variable-button '((t (:underline t :weight bold))) "Face used for pushable variable tags." :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-variable-button-face 'face-alias 'custom-variable-button) +(define-obsolete-face-alias 'custom-variable-button-face + 'custom-variable-button "22.1") (defcustom custom-variable-default-form 'edit "Default form of displaying variable values." @@ -2465,7 +2453,11 @@ However, setting it through Custom sets the default value.") (documentation-property variable 'variable-documentation))) (define-widget 'custom-variable 'custom - "Customize variable." + "A widget for displaying a Custom variable. + +The following property has a special meaning for this widget: +:hidden-states - A list of widget states for which the widget's initial + contents should be hidden." :format "%v" :help-echo "Set or reset this variable." :documentation-property #'custom-variable-documentation @@ -2475,6 +2467,7 @@ However, setting it through Custom sets the default value.") :custom-form nil ; defaults to value of `custom-variable-default-form' :value-create 'custom-variable-value-create :action 'custom-variable-action + :hidden-states '(standard) :custom-set 'custom-variable-set :custom-mark-to-save 'custom-variable-mark-to-save :custom-reset-current 'custom-redraw @@ -2509,7 +2502,6 @@ try matching its doc string against `custom-guess-doc-alist'." (let* ((buttons (widget-get widget :buttons)) (children (widget-get widget :children)) (form (widget-get widget :custom-form)) - (state (widget-get widget :custom-state)) (symbol (widget-get widget :value)) (tag (widget-get widget :tag)) (type (custom-variable-type symbol)) @@ -2519,17 +2511,17 @@ try matching its doc string against `custom-guess-doc-alist'." (last (widget-get widget :custom-last)) (value (if (default-boundp symbol) (funcall get symbol) - (widget-get conv :value)))) - ;; If the widget is new, the child determines whether it is hidden. - (cond (state) - ((custom-show type value) - (setq state 'unknown)) - (t - (setq state 'hidden))) + (widget-get conv :value))) + (state (or (widget-get widget :custom-state) + (if (memq (custom-variable-state symbol value) + (widget-get widget :hidden-states)) + 'hidden)))) + ;; If we don't know the state, see if we need to edit it in lisp form. + (unless state + (setq state (if (custom-show type value) 'unknown 'hidden))) (when (eq state 'unknown) (unless (widget-apply conv :match value) - ;; (widget-apply (widget-convert type) :match value) (setq form 'mismatch))) ;; Now we can create the child widget. (cond ((eq custom-buffer-style 'tree) @@ -2542,21 +2534,36 @@ try matching its doc string against `custom-guess-doc-alist'." ((eq state 'hidden) ;; Indicate hidden value. (push (widget-create-child-and-convert - widget 'item - :format "%{%t%}: " - :sample-face 'custom-variable-tag-face - :tag tag - :parent widget) - buttons) - (push (widget-create-child-and-convert - widget 'visibility + widget 'custom-visibility :help-echo "Show the value of this option." + :on-image "down" + :on "Hide" + :off-image "right" :off "Show Value" :action 'custom-toggle-parent nil) + buttons) + (insert " ") + (push (widget-create-child-and-convert + widget 'item + :format "%{%t%} " + :sample-face 'custom-variable-tag + :tag tag + :parent widget) buttons)) ((memq form '(lisp mismatch)) ;; In lisp mode edit the saved value when possible. + (push (widget-create-child-and-convert + widget 'custom-visibility + :help-echo "Hide the value of this option." + :on "Hide" + :off "Show" + :on-image "down" + :off-image "right" + :action 'custom-toggle-parent + t) + buttons) + (insert " ") (let* ((value (cond ((get symbol 'saved-value) (car (get symbol 'saved-value))) ((get symbol 'standard-value) @@ -2566,15 +2573,6 @@ try matching its doc string against `custom-guess-doc-alist'." (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." - :on "Hide Value" - :off "Show Value" - :action 'custom-toggle-parent - t) - buttons) - (insert " ") (push (widget-create-child-and-convert widget 'sexp :button-face 'custom-variable-button-face @@ -2585,6 +2583,17 @@ try matching its doc string against `custom-guess-doc-alist'." children))) (t ;; Edit mode. + (push (widget-create-child-and-convert + widget 'custom-visibility + :help-echo "Hide or show this option." + :on "Hide" + :off "Show" + :on-image "down" + :off-image "right" + :action 'custom-toggle-parent + t) + buttons) + (insert " ") (let* ((format (widget-get type :format)) tag-format value-format) (unless (string-match ":" format) @@ -2597,19 +2606,10 @@ try matching its doc string against `custom-guess-doc-alist'." :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 + :button-face 'custom-variable-button + :sample-face 'custom-variable-tag tag) buttons) - (insert " ") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide the value of this option." - :on "Hide Value" - :off "Show Value" - :action 'custom-toggle-parent - t) - buttons) (push (widget-create-child-and-convert widget type :format value-format @@ -2641,7 +2641,7 @@ try matching its doc string against `custom-guess-doc-alist'." ;; Don't push it !!! Custom assumes that the first child is the ;; value one. (setq children (append children (list comment-widget))))) - ;; Update the rest of the properties properties. + ;; Update the rest of the properties. (widget-put widget :custom-form form) (widget-put widget :children children) ;; Now update the state. @@ -2664,61 +2664,69 @@ try matching its doc string against `custom-guess-doc-alist'." (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)) +(defun custom-variable-state (symbol val) + "Return the state of SYMBOL if its value is VAL. +If SYMBOL has a non-nil `custom-get' property, it overrides VAL. +Possible return values are `standard', `saved', `set', `themed', +`changed', and `rogue'." + (let* ((get (or (get symbol 'custom-get) 'default-value)) (value (if (default-boundp symbol) (funcall get symbol) - (widget-get widget :value))) + val)) (comment (get symbol 'variable-comment)) tmp - temp - (state (cond ((progn (setq tmp (get symbol 'customized-value)) - (setq temp - (get symbol 'customized-variable-comment)) - (or tmp temp)) - (if (condition-case nil - (and (equal value (eval (car tmp))) - (equal comment temp)) - (error nil)) - 'set - 'changed)) - ((progn (setq tmp (get symbol 'theme-value)) - (setq temp (get symbol 'saved-variable-comment)) - (or tmp temp)) - (if (condition-case nil - (and (equal comment temp) - (equal value - (eval - (car (custom-variable-theme-value - symbol))))) - (error nil)) - (cond - ((eq (caar tmp) 'user) 'saved) - ((eq (caar tmp) 'changed) - (if (condition-case nil - (and (null comment) - (equal value - (eval - (car (get symbol 'standard-value))))) - (error nil)) - ;; The value was originally set outside - ;; custom, but it was set to the standard - ;; value (probably an autoloaded defcustom). - 'standard - 'changed)) - (t 'themed)) - 'changed)) - ((setq tmp (get symbol 'standard-value)) - (if (condition-case nil - (and (equal value (eval (car tmp))) - (equal comment nil)) - (error nil)) - 'standard - 'changed)) - (t 'rogue)))) - (widget-put widget :custom-state state))) + temp) + (cond ((progn (setq tmp (get symbol 'customized-value)) + (setq temp + (get symbol 'customized-variable-comment)) + (or tmp temp)) + (if (condition-case nil + (and (equal value (eval (car tmp))) + (equal comment temp)) + (error nil)) + 'set + 'changed)) + ((progn (setq tmp (get symbol 'theme-value)) + (setq temp (get symbol 'saved-variable-comment)) + (or tmp temp)) + (if (condition-case nil + (and (equal comment temp) + (equal value + (eval + (car (custom-variable-theme-value + symbol))))) + (error nil)) + (cond + ((eq (caar tmp) 'user) 'saved) + ((eq (caar tmp) 'changed) + (if (condition-case nil + (and (null comment) + (equal value + (eval + (car (get symbol 'standard-value))))) + (error nil)) + ;; The value was originally set outside + ;; custom, but it was set to the standard + ;; value (probably an autoloaded defcustom). + 'standard + 'changed)) + (t 'themed)) + 'changed)) + ((setq tmp (get symbol 'standard-value)) + (if (condition-case nil + (and (equal value (eval (car tmp))) + (equal comment nil)) + (error nil)) + 'standard + 'changed)) + (t 'rogue)))) + +(defun custom-variable-state-set (widget &optional state) + "Set the state of WIDGET to STATE. +If STATE is nil, the value is computed by `custom-variable-state'." + (widget-put widget :custom-state + (or state (custom-variable-state (widget-value widget) + (widget-get widget :value))))) (defun custom-variable-standard-value (widget) (get (widget-value widget) 'standard-value)) @@ -3004,7 +3012,9 @@ to switch between two values." :button-face 'custom-visibility :pressed-face 'custom-visibility :mouse-face 'highlight - :pressed-face 'highlight) + :pressed-face 'highlight + :on-image nil + :off-image nil) (defface custom-visibility '((t :height 0.8 :inherit link)) @@ -3213,8 +3223,7 @@ Only match frames that support the specified face attributes.") `((t :inherit custom-variable-tag)) "Face used for face tags." :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-face-tag-face 'face-alias 'custom-face-tag) +(define-obsolete-face-alias 'custom-face-tag-face 'custom-face-tag "22.1") (defcustom custom-face-default-form 'selected "Default form of displaying face definition." @@ -3226,7 +3235,7 @@ Only match frames that support the specified face attributes.") (define-widget 'custom-face 'custom "Customize face." - :sample-face 'custom-face-tag-face + :sample-face 'custom-face-tag :help-echo "Set or reset this face." :documentation-property #'face-doc-string :value-create 'custom-face-value-create @@ -3352,6 +3361,18 @@ SPEC must be a full face spec." (insert " " tag "\n") (widget-put widget :buttons buttons)) (t + ;; Visibility. + (push (widget-create-child-and-convert + widget 'custom-visibility + :help-echo "Hide or show this face." + :on "Hide" + :off "Show" + :on-image "down" + :off-image "right" + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons) + (insert " ") ;; Create tag. (insert tag) (widget-specify-sample widget begin (point)) @@ -3366,16 +3387,6 @@ SPEC must be a full face spec." :sample-face symbol :tag "sample") buttons) - ;; Visibility. - (insert " ") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide or show this face." - :on "Hide Face" - :off "Show Face" - :action 'custom-toggle-parent - (not (eq state 'hidden))) - buttons) ;; Magic. (insert "\n") (let ((magic (widget-create-child-and-convert @@ -3798,8 +3809,7 @@ and so forth. The remaining group tags are shown with `custom-group-tag'." (t (:weight bold))) "Face used for group tags." :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-group-tag-face-1 'face-alias 'custom-group-tag-1) +(define-obsolete-face-alias 'custom-group-tag-face-1 'custom-group-tag-1 "22.1") (defface custom-group-tag `((((class color) @@ -3814,8 +3824,7 @@ and so forth. The remaining group tags are shown with `custom-group-tag'." (t (:weight bold))) "Face used for low level group tags." :group 'custom-faces) -;; backward-compatibility alias -(put 'custom-group-tag-face 'face-alias 'custom-group-tag) +(define-obsolete-face-alias 'custom-group-tag-face 'custom-group-tag "22.1") (define-widget 'custom-group 'custom "Customize group." @@ -3874,7 +3883,8 @@ If GROUPS-ONLY non-nil, return only those members that are groups." (symbol (widget-value widget)) (members (custom-group-members symbol (and (eq custom-buffer-style 'tree) - custom-browse-only-groups)))) + custom-browse-only-groups))) + (doc (widget-docstring widget))) (cond ((and (eq custom-buffer-style 'tree) (eq state 'hidden) (or members (custom-unloaded-widget-p widget))) @@ -3928,8 +3938,11 @@ If GROUPS-ONLY non-nil, return only those members that are groups." (insert " " tag "\n") (widget-put widget :buttons buttons) (message "Creating group...") - (let* ((members (custom-sort-items members - custom-browse-sort-alphabetically + (let* ((members (custom-sort-items + members + ;; Never sort the top-level custom group. + (unless (eq symbol 'emacs) + custom-browse-sort-alphabetically) custom-browse-order-groups)) (prefixes (widget-get widget :custom-prefixes)) (custom-prefix-list (custom-prefix-add symbol prefixes)) @@ -3987,22 +4000,30 @@ If GROUPS-ONLY non-nil, return only those members that are groups." ;; Nested style. (t ;Visible. + ;; Draw a horizontal line (this works for both graphical + ;; and text displays): + (let ((p (point))) + (insert "\n") + (put-text-property p (1+ p) 'face '(:underline t)) + (overlay-put (make-overlay p (1+ p)) + 'before-string + (propertize "\n" 'face '(:underline t) + 'display '(space :align-to 999)))) + ;; 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 - "Parent groups:" - "Parent group documentation:") - (insert "\n")))) - ;; Create level indicator. + (when (eq level 1) + (if (custom-add-parent-links widget "Parent groups:") + (insert "\n"))) (insert-char ?\ (* custom-buffer-indent (1- level))) - (insert "/- ") ;; Create tag. (let ((start (point))) (insert tag " group: ") (widget-specify-sample widget start (point))) - (insert (widget-docstring widget)) + (cond + ((not doc) + (insert " Group definition missing. ")) + ((< (length doc) 50) + (insert doc))) ;; Create visibility indicator. (unless (eq custom-buffer-style 'links) (insert "--------") @@ -4013,12 +4034,7 @@ If GROUPS-ONLY non-nil, return only those members that are groups." (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") + (insert "\n") ;; Create magic button. (let ((magic (widget-create-child-and-convert widget 'custom-magic @@ -4029,8 +4045,9 @@ If GROUPS-ONLY non-nil, return only those members that are groups." ;; Update buttons. (widget-put widget :buttons buttons) ;; Insert documentation. - (widget-add-documentation-string-button - widget :visibility-widget 'custom-visibility) + (when (and doc (>= (length doc) 50)) + (widget-add-documentation-string-button + widget :visibility-widget 'custom-visibility)) ;; Parent groups. (if nil ;;; This should test that the buffer @@ -4043,43 +4060,50 @@ If GROUPS-ONLY non-nil, return only those members that are groups." ?\ )) ;; Members. (message "Creating group...") - (let* ((members (custom-sort-items members - custom-buffer-sort-alphabetically - custom-buffer-order-groups)) + (let* ((members (custom-sort-items + members + ;; Never sort the top-level custom group. + (unless (eq symbol 'emacs) + 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)) + (len (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...") + (reporter (make-progress-reporter + "Creating group entries..." 0 len)) + children) + (setq children + (mapcar + (lambda (entry) + (widget-insert "\n") + (progress-reporter-update reporter (setq count (1+ count))) + (let ((sym (nth 0 entry)) + (type (nth 1 entry)) + hidden-p) + (prog1 + (widget-create-child-and-convert + widget type + :group widget + :tag (custom-unlispify-tag-name sym) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :value sym) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n"))))) + members)) (mapc 'custom-magic-reset children) - (message "Creating group state...") (widget-put widget :children children) (custom-group-state-update widget) - (message "Creating group... done")) + (progress-reporter-done reporter)) ;; 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"))))) + (let ((p (point))) + (insert "\n") + (put-text-property p (1+ p) 'face '(:underline t)) + (overlay-put (make-overlay p (1+ p)) + 'before-string + (propertize "\n" 'face '(:underline t) + 'display '(space :align-to 999)))))))) (defvar custom-group-menu `(("Set for Current Session" custom-group-set @@ -4638,7 +4662,7 @@ The following commands are available: \\\ Move to next button, link or editable field. \\[widget-forward] -Move to previous button, link or editable field. \\[advertised-widget-backward] +Move to previous button, link or editable field. \\[widget-backward] \\\ Complete content of editable text field. \\[widget-complete] \\\ @@ -4655,17 +4679,17 @@ Entry to this mode calls the value of `Custom-mode-hook' if that value is non-nil." (use-local-map custom-mode-map) (easy-menu-add Custom-mode-menu) - (when (display-graphic-p) - (set (make-local-variable 'tool-bar-map) - (or custom-tool-bar-map - ;; Set up `custom-tool-bar-map'. - (let ((map (make-sparse-keymap))) - (mapc - (lambda (arg) - (tool-bar-local-item-from-menu - (nth 1 arg) (nth 4 arg) map custom-mode-map)) - custom-commands) - (setq custom-tool-bar-map map))))) + (set (make-local-variable 'tool-bar-map) + (or custom-tool-bar-map + ;; Set up `custom-tool-bar-map'. + (let ((map (make-sparse-keymap))) + (mapc + (lambda (arg) + (tool-bar-local-item-from-menu + (nth 1 arg) (nth 4 arg) map custom-mode-map + :label (nth 5 arg))) + custom-commands) + (setq custom-tool-bar-map map)))) (make-local-variable 'custom-options) (make-local-variable 'custom-local-buffer) (make-local-variable 'widget-documentation-face)