xemacs-beta: lisp/custom/cus-edit.el comparison

comparison lisp/custom/cus-edit.el @ 165:5a88923fcbfe r20-3b9

Import from CVS: tag r20-3b9

author	cvs
date	Mon, 13 Aug 2007 09:44:42 +0200
parents	0132846995bd
children	85ec50267440

comparison

equal deleted inserted replaced

-:4e0740e5aab2
+:5a88923fcbfe
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: help, faces
-;; Version: 1.9931
+;; Version: 1.9937
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;; This file is part of GNU Emacs.
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;;; 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)
 (defgroup custom-faces nil
 "Faces used by customize."
 :group 'customize
 :group 'faces)
-(defgroup custom-buffer nil
+(defgroup custom-browse nil
-"Control the customize buffers."
+"Control customize browser."
 :prefix "custom-"
 :group 'customize)
+(defgroup custom-buffer nil
+"Control customize buffers."
+:prefix "custom-"
+:group 'customize)
 (defgroup custom-menu nil
-"Control how the customize menus."
+"Control customize menus."
 :prefix "custom-"
 :group 'customize)
 (defgroup abbrev-mode nil
 "Word abbreviations mode."
 		    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-buffer-sort-alphabetically nil
-"If non-nil, sort the members of each customization group alphabetically."
+"If non-nil, sort members of each customization group alphabetically."
 :type 'boolean
 :group 'custom-buffer)
-(defcustom custom-buffer-groups-last nil
+(defcustom custom-buffer-order-groups 'last
-"If non-nil, put subgroups after all ordinary options within a group."
+"If non-nil, order group members within each customization group.
-:type 'boolean
+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 the members of each customization group alphabetically."
+"If non-nil, sort members of each customization group alphabetically."
 :type 'boolean
 :group 'custom-menu)
-(defcustom custom-menu-groups-first t
+(defcustom custom-menu-order-groups 'first
-"If non-nil, put subgroups before all ordinary options within a group."
+"If non-nil, order group members within each customization group.
-:type 'boolean
+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)
-(defun custom-buffer-sort-predicate (a b)
+(defun custom-sort-items (items sort-alphabetically order-groups)
-"Return t iff A should come before B in a customization buffer.
+"Return a sorted copy of ITEMS.
-A and B should be members of a `custom-group' property."
+ITEMS should be a `custom-group' property.
-(cond ((and (not custom-buffer-groups-last)
+If SORT-ALPHABETICALLY non-nil, sort alphabetically.
-	      (not custom-buffer-sort-alphabetically))
+If ORDER-GROUPS is `first' order groups before non-groups, if `last' order
-	 nil)
+groups after non-groups, if nil do not order groups at all."
-	((or (eq (eq (nth 1 a) 'custom-group) (eq (nth 1 b) 'custom-group))
+(sort (copy-sequence items)
-	     (not custom-buffer-groups-last))
+(lambda (a b)
-	 (if custom-buffer-sort-alphabetically
+(let ((typea (nth 1 a)) (typeb (nth 1 b))
-	     (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))
+	   (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b))))
-	   nil))
+(cond ((not order-groups)
-	(t
+	      ;; Since we don't care about A and B order, maybe sort.
-	 (not (eq (nth 1 a) 'custom-group) ))))
+	      (when sort-alphabetically
+		(string-lessp namea nameb)))
-(defalias 'custom-browse-sort-predicate 'ignore)
+	     ((eq typea 'custom-group)
+	      ;; If B is also a group, maybe sort.  Otherwise, order A and B.
-(defun custom-menu-sort-predicate (a b)
+	      (if (eq typeb 'custom-group)
-"Return t iff A should come before B in a customization menu.
+		  (when sort-alphabetically
-A and B should be members of a `custom-group' property."
+		    (string-lessp namea nameb))
-(cond ((and (not custom-menu-groups-first)
+		(eq order-groups 'first)))
-	      (not custom-menu-sort-alphabetically))
+	     ((eq typeb 'custom-group)
-	 nil)
+	      ;; Since A cannot be a group, order A and B.
-	((or (eq (eq (nth 1 a) 'custom-group) (eq (nth 1 b) 'custom-group))
+	      (eq order-groups 'last))
-	     (not custom-menu-groups-first))
+	     (sort-alphabetically
-	 (if custom-menu-sort-alphabetically
+	      ;; Since A and B cannot be groups, sort.
-	     (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))
+	      (string-lessp namea nameb)))))))
-	   nil))
-	(t
-	 (eq (nth 1 a) 'custom-group) )))
 ;;; 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))
 (mapcar (lambda (child)
 	      (when (eq (widget-get child :custom-state) 'modified)
 		(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))
 (mapcar (lambda (child)
 	      (when (memq (widget-get child :custom-state) '(modified set))
 		(widget-apply child :custom-save)))
 	    children))
 (custom-save-all))
 (defvar custom-reset-menu
-'(("Current" . custom-reset-current)
+'(("Current" . Custom-reset-current)
-("Saved" . custom-reset-saved)
+("Saved" . Custom-reset-saved)
-("Standard Settings" . custom-reset-standard))
+("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
 when the action is chosen.")
 				custom-reset-menu
 				event)))
 (if answer
 	(funcall answer))))
-(defun custom-reset-current (&rest ignore)
+(defun Custom-reset-current (&rest ignore)
 "Reset all modified group members to their current value."
 (interactive)
 (let ((children custom-options))
 (mapcar (lambda (child)
 	      (when (eq (widget-get child :custom-state) 'modified)
 		(widget-apply child :custom-reset-current)))
 	    children)))
-(defun custom-reset-saved (&rest ignore)
+(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-saved)))
 	    children)))
-(defun custom-reset-standard (&rest ignore)
+(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)
 					(not (boundp var))))
 		  (t
 		   (eval-minibuffer prompt)))))))
 ;;;###autoload
-(defun custom-set-value (var val)
+(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.
 				       "Set %s to value: "))
 (set var val))
 ;;;###autoload
-(defun custom-set-variable (var val)
+(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.
 "Customize SYMBOL, which should be a face name or nil.
 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))
+(custom-buffer-create (custom-sort-items
-	(message "Looking for faces...")
+			     (mapcar (lambda (symbol)
-	(mapcar (lambda (symbol)
+				       (list symbol 'custom-face))
-		  (push (list symbol 'custom-face) found))
+				     (face-list))
-		(nreverse (mapcar 'intern
+			     t nil)
-				  (sort (mapcar 'symbol-name (face-list))
+			    "*Customize Faces*")
-					'string-lessp))))
+(when (stringp symbol)
+(setq symbol (intern symbol)))
-	(custom-buffer-create found "*Customize Faces*"))
-(if (stringp symbol)
-	(setq symbol (intern symbol)))
 (unless (symbolp symbol)
 (error "Should be a symbol %S" symbol))
 (custom-buffer-create (list (list symbol 'custom-face))
 			  (format "*Customize Face: %s*"
 				  (custom-unlispify-tag-name symbol)))))
 		     (custom-facep symbol)
 		     (push (list symbol 'custom-face) found))
 		(and (get symbol 'customized-value)
 		     (boundp symbol)
 		     (push (list symbol 'custom-variable) found))))
-(if found
+(if (not found)
-	(custom-buffer-create found "*Customize Customized*")
+	(error "No customized user options")
-(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)
 		     (custom-facep symbol)
 		     (push (list symbol 'custom-face) found))
 		(and (get symbol 'saved-value)
 		     (boundp symbol)
 		     (push (list symbol 'custom-variable) found))))
-(if found
+(if (not found )
-	(custom-buffer-create found "*Customize Saved*")
+	(error "No saved user options")
-(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 is `options', include only options.
 				     (user-variable-p symbol)
 				   (get symbol 'variable-documentation))))
 		    (push (list symbol 'custom-variable) found)))))
 (if (not found)
 	(error "No matches")
-(let ((custom-buffer-sort-alphabetically t))
+(custom-buffer-create (custom-sort-items found t
-	(custom-buffer-create (sort found 'custom-buffer-sort-predicate)
+					       custom-buffer-order-groups)
-			      "*Customize Apropos*")))))
+			    "*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."
 (defun custom-buffer-create-internal (options)
 (message "Creating customization buffer...")
 (custom-mode)
 (widget-insert "This is a customization buffer.
-Push RET or click mouse-2 on the word ")
+Square brackets show active fields; type RET or click mouse-2
+on an active field to invoke its action.  Invoke ")
 (widget-create 'info-link
-		 :tag "help"
+		 :tag "Help"
 		 :help-echo "Read the online help."
 		 "(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"
-		 :help-echo "Set all modifications for this session."
+		 :help-echo "\
+Make your editing in this buffer take effect for this session."
 		 :action (lambda (widget &optional event)
-			   (custom-set)))
+			   (Custom-set)))
 (widget-insert " ")
 (widget-create 'push-button
 		 :tag "Save"
 		 :help-echo "\
-Make the modifications default for future sessions."
+Make your editing in this buffer take effect for future Emacs sessions."
 		 :action (lambda (widget &optional event)
-			   (custom-save)))
+			   (Custom-save)))
 (widget-insert " ")
 (if custom-reset-button-menu
 (widget-create 'push-button
 		     :tag "Reset"
 		     :help-echo "Show a menu with reset operations."
 		     :action (lambda (widget &optional event)
 			       (custom-reset event)))
 (widget-create 'push-button
 		   :tag "Reset"
 		   :help-echo "\
-Reset all visible items in this buffer to their current settings."
+Reset all edited text in this buffer to reflect current values."
-		   :action 'custom-reset-current)
+		   :action 'Custom-reset-current)
 (widget-insert " ")
 (widget-create 'push-button
 		   :tag "Reset to Saved"
 		   :help-echo "\
-Reset all visible items in this buffer to their saved settings."
+Reset all values in this buffer to their saved settings."
-		   :action 'custom-reset-saved)
+		   :action 'Custom-reset-saved)
 (widget-insert " ")
 (widget-create 'push-button
 		   :tag "Reset to Standard"
 		   :help-echo "\
-Reset all visible items in this buffer to their standard settings."
+Reset all values in this buffer to their standard settings."
-		   :action 'custom-reset-standard))
+		   :action 'Custom-reset-standard))
-(widget-insert " ")
+(widget-insert "   ")
 (widget-create 'push-button
-		 :tag "Done"
+		 :tag "Bury Buffer"
 		 :help-echo "Bury the buffer."
 		 :action (lambda (widget &optional event)
 			   (bury-buffer)))
 (widget-insert "\n\n")
 (message "Creating customization items...")
 (message "Creating customization buffer...done"))
 ;;; The Tree Browser.
 ;;;###autoload
-(defun customize-browse ()
+(defun customize-browse (group)
 "Create a tree browser for the customize hierarchy."
-(interactive)
+(interactive (list (let ((completion-ignore-case t))
+		       (completing-read "Customize group: (default emacs) "
+					obarray
+					(lambda (symbol)
+					  (get symbol 'custom-group))
+					t))))
+(when (stringp group)
+(if (string-equal "" group)
+	(setq group 'emacs)
+(setq group (intern group))))
 (let ((name "*Customize Browser*"))
 (kill-buffer (get-buffer-create name))
 (switch-to-buffer (get-buffer-create name)))
 (custom-mode)
 (widget-insert "\
 Invoke [+] below to expand items, and [-] to collapse items.
-Invoke the [group], [face], and [option] buttons below to edit that
+Invoke the [Group], [Face], and [Option] 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 'emacs)
+		   :tag (custom-unlispify-tag-name group)
-		   :value 'emacs))
+		   :value group))
 (goto-char (point-min)))
 (define-widget 'custom-tree-visibility 'item
 "Control visibility of of items in the customize tree browser."
 :format "%[[%t]%]"
 (let ((custom-buffer-style 'tree))
 (custom-toggle-parent widget)))
 (define-widget 'custom-tree-group-tag 'push-button
 "Show parent in other window when activated."
-:tag "group"
+:tag "Group"
 :tag-glyph "folder"
 :action 'custom-tree-group-tag-action)
 (defun custom-tree-group-tag-action (widget &rest ignore)
 (let ((parent (widget-get widget :parent)))
 (customize-group-other-window (widget-value parent))))
 (define-widget 'custom-tree-variable-tag 'push-button
 "Show parent in other window when activated."
-:tag "option"
+:tag "Option"
 :tag-glyph "option"
 :action 'custom-tree-variable-tag-action)
 (defun custom-tree-variable-tag-action (widget &rest ignore)
 (let ((parent (widget-get widget :parent)))
 (customize-variable-other-window (widget-value parent))))
 (define-widget 'custom-tree-face-tag 'push-button
 "Show parent in other window when activated."
-:tag "face"
+:tag "Face"
 :tag-glyph "face"
 :action 'custom-tree-face-tag-action)
 (defun custom-tree-face-tag-action (widget &rest ignore)
 (let ((parent (widget-get widget :parent)))
 (customize-face-other-window (widget-value parent))))
 (defconst custom-tree-alist '(("   " "space")
 			      (" | " "vertical")
+			      ("-\\ " "top")
 			      (" |-" "middle")
 			      (" `-" "bottom")))
-(defun custom-tree-insert (prefix)
+(defun custom-tree-insert-prefix (prefix)
 "Insert PREFIX.  On XEmacs convert it to line graphics."
-(if nil ;(string-match "XEmacs" emacs-version)
+(if nil ; (string-match "XEmacs" emacs-version)
-(while (not (string-equal prefix ""))
+(progn
-	(let ((entry (substring prefix 0 3)))
+	(insert "*")
-	  (setq prefix (substring prefix 3))
+	(while (not (string-equal prefix ""))
-	  (widget-specify-insert
+	  (let ((entry (substring prefix 0 3)))
-	   (widget-glyph-insert nil entry
+	    (setq prefix (substring prefix 3))
-				(nth 1 (assoc entry custom-tree-alist))))))
+	    (let ((overlay (make-overlay (1- (point)) (point) nil t nil))
+		  (name (nth 1 (assoc entry custom-tree-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
 The list should be sorted most significant first.")
 (defcustom custom-magic-show 'long
 "If non-nil, show textual description of the state.
-If non-nil and not the symbol `long', only show first word."
+If `long', show a full-line description, not just one word."
 :type '(choice (const :tag "no" nil)
 		 (const short)
 		 (const long))
 :group 'custom-buffer)
 (defcustom custom-magic-show-hidden '(option face)
-"Control whether the state button is shown for hidden items.
+"Control whether the State button is shown for hidden items.
-The value should be a list with the custom categories where the state
+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."
+"Show a \"magic\" button indicating the state of each customization option."
 :type 'boolean
 :group 'custom-buffer)
 (define-widget 'custom-magic 'default
 "Show and manipulate state for a customization option."
 			 (match-string 2 text))))
 (when (and custom-magic-show
 	       (or (not hidden)
 		   (memq category custom-magic-show-hidden)))
 (insert "   ")
-(when (eq category 'group)
+(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."
 	     :button-suffix 'widget-push-button-suffix
 	     :mouse-down-action 'widget-magic-mouse-down-action
 	     :tag "State")
 	    children)
 (insert ": ")
-(if (eq custom-magic-show 'long)
+(let ((start (point)))
-	  (insert text)
+	(if (eq custom-magic-show 'long)
-	(insert (symbol-name state)))
+	    (insert text)
-(when lisp
+	  (insert (symbol-name state)))
-	(insert " (lisp)"))
+	(when lisp
+	  (insert " (lisp)"))
+	(put-text-property start (point) 'face 'custom-state-face))
 (insert "\n"))
-(when (eq category 'group)
+(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)))
 (let ((magic (widget-get widget :custom-magic)))
 (widget-value-set magic (widget-value magic))))
 ;;; The `custom' Widget.
+(defface custom-button-face nil
+"Face used for buttons in customization buffers."
+:group 'custom-faces)
+(defface custom-documentation-face nil
+"Face used for documentation strings in customization buffers."
+:group 'custom-faces)
+(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
 :notify 'custom-notify
 :documentation-property 'widget-subclass-responsibility
 :value-create 'widget-subclass-responsibility
 :value-delete 'widget-children-value-delete
 :value-get 'widget-value-value-get
 :validate 'widget-children-validate
+:button-face 'custom-button-face
 :match (lambda (widget value) (symbolp value)))
 (defun custom-convert-widget (widget)
 ;; Initialize :value and :tag from :args in WIDGET.
 (let ((args (widget-get widget :args)))
 	   (widget-put widget :custom-state 'hidden)))
 (custom-redraw widget)
 (widget-setup)))
 (defun custom-toggle-parent (widget &rest ignore)
-"Toggle visibility of parent to WIDGET."
+"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."
 		 (insert " and ")))
 	      (t
 	       (insert ", "))))
 (widget-put widget :buttons buttons))))
-(defun custom-add-parent-links (widget)
+(defun custom-add-parent-links (widget &optional initial-string)
-"Add `Parent groups: ...' to WIDGET."
+"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 "Parent groups:")
+(insert (or initial-string "Parent groups:"))
 (mapatoms (lambda (symbol)
-		(let ((group (get symbol 'custom-group)))
+		(let ((entry (assq name (get symbol 'custom-group))))
-		  (when (assq name group)
+		  (when (eq (nth 1 entry) type)
-		    (when (eq type (nth 1 (assq name group)))
+		    (insert " ")
-		      (insert " ")
+		    (push (widget-create-child-and-convert
-		      (push (widget-create-child-and-convert
+			   widget 'custom-group-link
-			     widget 'custom-group-link
+			   :tag (custom-unlispify-tag-name symbol)
-			     :tag (custom-unlispify-tag-name symbol)
+			   symbol)
-			     symbol)
+			  buttons)
-			    buttons)
+		    (setq found t)))))
-		      (setq found t))))))
 (widget-put widget :buttons buttons)
-(unless found
+(if found
-(insert " (none)"))
+	(insert "\n")
-(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)
 (defface custom-variable-button-face '((t (:underline t :bold t)))
 "Face used for pushable variable tags."
 	  ((eq state 'hidden)
 	   ;; Indicate hidden value.
 	   (push (widget-create-child-and-convert
 		  widget 'item
 		  :format "%{%t%}: "
-		  :sample-face 'custom-variable-sample-face
+		  :sample-face 'custom-variable-tag-face
 		  :tag tag
 		  :parent widget)
 		 buttons)
 	   (push (widget-create-child-and-convert
 		  widget 'visibility
 		    :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-sample-face
+		    :sample-face 'custom-variable-tag-face
 		    tag)
 		   buttons)
 	     (insert " ")
 	     (push (widget-create-child-and-convert
 		  widget 'visibility
 ;;; The `custom-group-link' Widget.
 (define-widget 'custom-group-link 'link
 "Show parent in other window when activated."
-:help-echo "Create customize buffer for this group group."
+: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,
 and so forth.  The remaining group tags are shown with
 `custom-group-tag-face'."
 (defun custom-group-sample-face-get (widget)
 ;; Use :sample-face.
 (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-value-create (widget)
 "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))
 	(buttons (widget-get widget :buttons))
 	(tag (widget-get widget :tag))
 	(symbol (widget-value widget)))
 (cond ((and (eq custom-buffer-style 'tree)
 		(eq state 'hidden))
-	   (custom-tree-insert prefix)
+	   (custom-tree-insert-prefix prefix)
 	   (push (widget-create-child-and-convert
 		  widget 'custom-tree-visibility
 		  ;; :tag-glyph "plus"
 		  :tag "+")
 		 buttons)
 		 buttons)
 	   (insert " " tag "\n")
 	   (widget-put widget :buttons buttons))
 	  ((and (eq custom-buffer-style 'tree)
 		(zerop (length (get symbol 'custom-group))))
-	   (custom-tree-insert prefix)
+	   (custom-tree-insert-prefix prefix)
 	   (insert "[ ]-- ")
 	   ;; (widget-glyph-insert nil "[ ]" "empty")
 	   ;; (widget-glyph-insert nil "-- " "horizontal")
 	   (push (widget-create-child-and-convert
 		  widget 'custom-tree-group-tag)
 		 buttons)
 	   (insert " " tag "\n")
 	   (widget-put widget :buttons buttons))
 	  ((eq custom-buffer-style 'tree)
-	   (custom-tree-insert prefix)
+	   (custom-tree-insert-prefix prefix)
 	   (custom-load-widget widget)
 	   (if (zerop (length (get symbol 'custom-group)))
 	       (progn
-		 (custom-tree-insert prefix)
+		 (custom-tree-insert-prefix prefix)
 		 (insert "[ ]-- ")
 		 ;; (widget-glyph-insert nil "[ ]" "empty")
 		 ;; (widget-glyph-insert nil "-- " "horizontal")
 		 (push (widget-create-child-and-convert
 			widget 'custom-tree-group-tag)
 	     (push (widget-create-child-and-convert
 		    widget 'custom-tree-visibility
 		    ;; :tag-glyph "minus"
 		    :tag "-")
 		   buttons)
-	     (insert "-+ ")
+	     (insert "-\\ ")
-	     ;; (widget-glyph-insert nil "-+ " "top")
+	     ;; (widget-glyph-insert nil "-\\ " "top")
 	     (push (widget-create-child-and-convert
 		    widget 'custom-tree-group-tag)
 		   buttons)
 	     (insert " " tag "\n")
 	     (widget-put widget :buttons buttons)
 	     (message "Creating group...")
-	     (let* ((members (sort (copy-sequence (get symbol 'custom-group))
+	     (let* ((members (custom-sort-items (get symbol 'custom-group)
-				   'custom-browse-sort-predicate))
+			      custom-browse-sort-alphabetically
+			      custom-browse-order-groups))
 		    (prefixes (widget-get widget :custom-prefixes))
 		    (custom-prefix-list (custom-prefix-add symbol prefixes))
 		    (length (length members))
 		    (extra-prefix (if (widget-get widget :custom-last)
 				      "   "
 	       (widget-put widget :children (reverse children)))
 	     (message "Creating group...done")))
 	  ;; Nested style.
 	  ((eq state 'hidden)
 	   ;; Create level indicator.
-	   (insert-char ?\  (* custom-buffer-indent (1- level)))
+	   (unless (eq custom-buffer-style 'links)
-	   (insert "-- ")
+	     (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 "Show"
+		      :tag "Go to Group"
 		      symbol)
 		     buttons)
 	     (push (widget-create-child-and-convert
-		    widget 'visibility
+		    widget 'group-visibility
 		    :help-echo "Show members of this group."
 		    :action 'custom-toggle-parent
 		    (not (eq state 'hidden)))
 		   buttons))
 	   (insert " \n")
 	     (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)))
 	     (push magic buttons))
 	   ;; Update buttons.
 	   (widget-put widget :buttons buttons)
 	   ;; Insert documentation.
 	   (widget-default-format-handler widget ?h)
-	   ;; Parents and See also.
+	   ;; Parent groups.
-	   (when (eq level 1)
+	   (if nil  ;;; This should test that the buffer
-	     (insert-char ?\  custom-buffer-indent)
+		    ;;; was not made to display a group.
-	     (custom-add-parent-links widget))
+	       (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 (sort (copy-sequence (get symbol 'custom-group))
+	   (let* ((members (custom-sort-items (get symbol 'custom-group)
-				 'custom-buffer-sort-predicate))
+					      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)
 (princ ")")
 (unless (looking-at "\n")
 	(princ "\n")))))
 ;;;###autoload
-(defun custom-save-customized ()
+(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)))
 ;;; Menu support
 (unless (string-match "XEmacs" emacs-version)
 (defconst custom-help-menu
 '("Customize"
-["Update menu..." custom-menu-update t]
+["Update menu..." Custom-menu-update t]
+["Browse..." (customize-browse 'emacs) t]
 ["Group..." customize-group t]
 ["Variable..." customize-variable t]
 ["Face..." customize-face t]
 ["Saved..." customize-saved t]
 ["Set..." customize-customized t]
 (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)
+(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)
 (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))
-	      (members (sort (copy-sequence (get symbol 'custom-group))
+	      (members (custom-sort-items (get symbol 'custom-group)
-			     'custom-menu-sort-predicate)))
+					  custom-menu-sort-alphabetically
+					  custom-menu-order-groups)))
 	  (custom-load-symbol symbol)
 	  `(,(custom-unlispify-menu-entry symbol t)
 	    ,item
 	    "--"
 	    ,@(mapcar (lambda (entry)
 ;;; The Custom Mode.
 (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)
 (suppress-keymap custom-mode-map)
-(define-key custom-mode-map "q" 'bury-buffer))
+(define-key custom-mode-map " " 'scroll-up)
+(define-key custom-mode-map "\177" 'scroll-down)
-(easy-menu-define custom-mode-menu
+(define-key custom-mode-map "q" 'bury-buffer)
+(define-key custom-mode-map "u" 'Custom-goto-parent))
+(easy-menu-define Custom-mode-menu
 custom-mode-map
 "Menu used in customization buffers."
 `("Custom"
 ,(customize-menu-create 'customize)
-["Set" custom-set t]
+["Set" Custom-set t]
-["Save" custom-save t]
+["Save" Custom-save t]
-["Reset to Current" custom-reset-current t]
+["Reset to Current" Custom-reset-current t]
-["Reset to Saved" custom-reset-saved t]
+["Reset to Saved" Custom-reset-saved t]
-["Reset to Standard Settings" custom-reset-standard 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 '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.
 The following commands are available:
 Move to next button or editable field.     \\[widget-forward]
 Move to previous button or editable field. \\[widget-backward]
 Invoke button under the mouse pointer.     \\[widget-button-click]
 Invoke button under point.		   \\[widget-button-press]
-Set all modifications.			   \\[custom-set]
+Set all modifications.			   \\[Custom-set]
-Make all modifications default.		   \\[custom-save]
+Make all modifications default.		   \\[Custom-save]
-Reset all modified options. 		   \\[custom-reset-current]
+Reset all modified options. 		   \\[Custom-reset-current]
-Reset all modified or set options.	   \\[custom-reset-saved]
+Reset all modified or set options.	   \\[Custom-reset-saved]
-Reset all options.			   \\[custom-reset-standard]
+Reset all options.			   \\[Custom-reset-standard]
 Entry to this mode calls the value of `custom-mode-hook'
 if that value is non-nil."
 (kill-all-local-variables)
 (setq major-mode 'custom-mode
 	mode-name "Custom")
 (use-local-map custom-mode-map)
-(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-hook 'widget-edit-functions)
+(add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)
 (run-hooks 'custom-mode-hook))
 ;;; The End.
 (provide 'cus-edit)

Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-edit.el @ 165:5a88923fcbfe r20-3b9