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

comparison lisp/custom/cus-edit.el @ 149:538048ae2ab8 r20-3b1

Import from CVS: tag r20-3b1

author	cvs
date	Mon, 13 Aug 2007 09:36:16 +0200
parents	b980b6286996
children	59463afc5666

comparison

equal deleted inserted replaced

-:f659db2a1f73
+:538048ae2ab8
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: help, faces
-;; Version: 1.84
+;; Version: 1.97
 ;; 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
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
 ;;; Commentary:
 ;;
+;; This file implements the code to create and edit customize buffers.
+;;
 ;; See `custom.el'.
 ;;; Code:
 (require 'cus-face)
 (require 'wid-edit)
 (require 'easymenu)
+(eval-when-compile (require 'cl))
+(condition-case nil
+(require 'cus-load)
+(error nil))
 (define-widget-keywords :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)
 (defgroup i18n nil
 "Internationalization and alternate character-set support."
 :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)
 (let ((v (variable-at-point))
 	 (enable-recursive-minibuffers t)
 	 val)
 (setq val (completing-read
 		(if v
-		    (format "Customize variable (default %s): " v)
+		    (format "Customize variable: (default %s) " v)
 		  "Customize variable: ")
-		obarray 'boundp t))
+		obarray (lambda (symbol)
+			  (and (boundp symbol)
+			       (or (get symbol 'custom-type)
+				   (user-variable-p symbol))))))
 (list (if (equal val "")
 	       v (intern val)))))
+(defun custom-menu-filter (menu widget)
+"Convert MENU to the form used by `widget-choose'.
+MENU should be in the same format as `custom-variable-menu'.
+WIDGET is the widget to apply the filter entries of MENU on."
+(let ((result nil)
+	current name action filter)
+(while menu
+(setq current (car menu)
+	    name (nth 0 current)
+	    action (nth 1 current)
+	    filter (nth 2 current)
+	    menu (cdr menu))
+(if (or (null filter) (funcall filter widget))
+	  (push (cons name action) result)
+	(push name result)))
+(nreverse result)))
 ;;; Unlispify.
 (defvar custom-prefix-list nil
 "List of prefixes that should be ignored by `custom-unlispify'")
 		(widget-apply child :custom-reset-current)))
 	    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 custom-set-value (var val)
+"Set VARIABLE to VALUE.  VALUE is a Lisp object.
+If VARIABLE has a `variable-interactive' property, that is used as if
+it were the arg to `interactive' (which see) to interactively read the value.
+If VARIABLE has a `custom-type' property, it must be a widget and the
+`:prompt-value' property of that widget will be used for reading the value."
+(interactive (custom-prompt-variable "Set variable: "
+				       "Set %s to value: "))
+(set var val))
+;;;###autoload
+(defun custom-set-variable (var val)
+"Set the default for VARIABLE to VALUE.  VALUE is a Lisp object.
+If VARIABLE has a `custom-set' property, that is used for setting
+VARIABLE, otherwise `set-default' is used.
+The `customized-value' property of the VARIABLE will be set to a list
+with a quoted VALUE as its sole list member.
+If VARIABLE has a `variable-interactive' property, that is used as if
+it were the arg to `interactive' (which see) to interactively read the value.
+If VARIABLE has a `custom-type' property, it must be a widget and the
+`:prompt-value' property of that widget will be used for reading the value. "
+(interactive (custom-prompt-variable "Set variable: "
+				       "Set customized value for %s to: "))
+(funcall (or (get var 'custom-set) 'set-default) var val)
+(put var 'customized-value (list (custom-quote val))))
 ;;;###autoload
 (defun customize (symbol)
 "Customize SYMBOL, which must be a customization group."
 (interactive (list (completing-read "Customize group: (default emacs) "
 				      obarray
 (when (stringp symbol)
 (if (string-equal "" symbol)
 	(setq symbol 'emacs)
 (setq symbol (intern symbol))))
-(custom-buffer-create (list (list symbol 'custom-group))))
+(custom-buffer-create (list (list symbol 'custom-group))
+			(format "*Customize Group: %s*"
+				(custom-unlispify-tag-name symbol))))
+;;;###autoload
+(defun customize-other-window (symbol)
+"Customize SYMBOL, which must be a customization group."
+(interactive (list (completing-read "Customize group: (default emacs) "
+				      obarray
+				      (lambda (symbol)
+					(get symbol 'custom-group))
+				      t)))
+(when (stringp symbol)
+(if (string-equal "" symbol)
+	(setq symbol 'emacs)
+(setq symbol (intern symbol))))
+(custom-buffer-create-other-window
+(list (list symbol 'custom-group))
+(format "*Customize Group: %s*" (custom-unlispify-tag-name symbol))))
 ;;;###autoload
 (defun customize-variable (symbol)
 "Customize SYMBOL, which must be a variable."
 (interactive (custom-variable-prompt))
-(custom-buffer-create (list (list symbol 'custom-variable))))
+(custom-buffer-create (list (list symbol 'custom-variable))
+			(format "*Customize Variable: %s*"
+				(custom-unlispify-tag-name symbol))))
 ;;;###autoload
 (defun customize-variable-other-window (symbol)
 "Customize SYMBOL, which must be a 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 Variable: %s*" (custom-unlispify-tag-name symbol))))
 ;;;###autoload
 (defun customize-face (&optional symbol)
 "Customize SYMBOL, which should be a face name or nil.
 If SYMBOL is nil, customize all faces."
 		  (setq found (cons (list symbol 'custom-face) found)))
 		(nreverse (mapcar 'intern
 				  (sort (mapcar 'symbol-name (face-list))
 					'string<))))
-	(custom-buffer-create found))
+	(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)))))
+(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)
 "Show customization buffer for FACE in other window."
 (interactive (list (completing-read "Customize face: "
 ()
 (if (stringp symbol)
 	(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)
+		     (setq found (cons (list symbol 'custom-face) found)))
+		(and (get symbol 'customized-value)
+		     (boundp symbol)
+		     (setq found
+			   (cons (list symbol 'custom-variable) found)))))
+(if found
+	(custom-buffer-create found "*Customize Customized*")
+(error "No customized user options"))))
+;;;###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)
 		(and (get symbol 'saved-value)
 		     (boundp symbol)
 		     (setq found
 			   (cons (list symbol 'custom-variable) found)))))
 (if found
-	(custom-buffer-create found)
+	(custom-buffer-create found "*Customize Saved*")
-(error "No customized user options"))))
+(error "No saved user options"))))
 ;;;###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
 				     (get symbol 'variable-documentation)
 				   (user-variable-p symbol))))
 		    (setq found
 			  (cons (list symbol 'custom-variable) found))))))
 (if found
-	(custom-buffer-create found)
+	(custom-buffer-create found "*Customize Apropos*")
 (error "No matches"))))
+;;; Buffer.
 ;;;###autoload
-(defun custom-buffer-create (options)
+(defun custom-buffer-create (options &optional name)
 "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*"))
+(unless name (setq name "*Customization*"))
-(switch-to-buffer (get-buffer-create "*Customization*"))
+(kill-buffer (get-buffer-create name))
+(switch-to-buffer (get-buffer-create name))
 (custom-buffer-create-internal options))
-(defun custom-buffer-create-other-window (options)
+;;;###autoload
+(defun custom-buffer-create-other-window (options &optional name)
 "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*"))
+(unless name (setq name "*Customization*"))
+(kill-buffer (get-buffer-create name))
 (let ((window (selected-window)))
-(switch-to-buffer-other-window (get-buffer-create "*Customization*"))
+(switch-to-buffer-other-window (get-buffer-create name))
 (custom-buffer-create-internal options)
 (select-window window)))
 (defun custom-buffer-create-internal (options)
 (widget-insert " ")
 (widget-create 'push-button
 		 :tag "Done"
 		 :help-echo "Bury the buffer."
 		 :action (lambda (widget &optional event)
-			   (bury-buffer)
+			   (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 setup...")
 (widget-setup)
 (goto-char (point-min))
-(forward-char)			;Kludge: bob is writable in XEmacs.
+(when (fboundp 'map-extents)
+;; This horrible kludge should make bob and eob read-only in XEmacs.
+(map-extents (lambda (extent &rest junk)
+		   (set-extent-property extent 'start-closed t))
+		 nil (point-min) (1+ (point-min)))
+(map-extents (lambda (extent &rest junk)
+		   (set-extent-property extent 'end-closed t))
+		 nil (1- (point-max)) (point-max)))
 (message "Creating customization buffer...done"))
 ;;; Modification of Basic Widgets.
 ;;
 ;; We add extra properties to the basic widgets needed here.  This is
 :group 'customize)
 (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))
 	 (face (nth 2 entry))
 	 (text (nth 3 entry))
 	 (lisp (eq (widget-get parent :custom-form) 'lisp))
 	 children)
 (when custom-magic-show
-(push (widget-create-child-and-convert widget 'choice-item
+(push (widget-create-child-and-convert
-					     :help-echo "\
+	     widget 'choice-item
+	     :help-echo "\
 Change the state of this item."
-					     :format "%[%t%]"
+	     :format "%[%t%]"
-					     :tag "State")
+	     :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 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
+(push (widget-create-child-and-convert
-					     :button-face face
+	     widget 'choice-item
-					     :help-echo "Change the state."
+	     :mouse-down-action 'widget-magic-mouse-down-action
-					     :format "%[%t%]"
+	     :button-face face
-					     :tag (if lisp
+	     :help-echo "Change the state."
-						      (concat "(" magic ")")
+	     :format "%[%t%]"
-						    (concat "[" magic "]")))
+	     :tag (if lisp
+		      (concat "(" magic ")")
+		    (concat "[" magic "]")))
 	    children)
 (insert " "))
 (widget-put widget :children children)))
 (defun custom-magic-reset (widget)
 :help-echo "Expand or collapse this item."
 :action 'custom-level-action)
 (defun custom-level-action (widget &optional event)
 "Toggle visibility for parent to WIDGET."
-(let* ((parent (widget-get widget :parent))
+(custom-toggle-hide (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)))
 ;;; The `custom' Widget.
 (define-widget 'custom 'default
 "Customize a user option."
 :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
+:value-get 'widget-value-value-get
-:validate 'widget-editable-list-validate
+:validate 'widget-children-validate
 :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)))
 (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)))
 (defun custom-load-widget (widget)
 "Load all dependencies for WIDGET."
 (custom-load-symbol (widget-value widget)))
+(defun custom-toggle-hide (widget)
+"Toggle visibility of WIDGET."
+(let ((state (widget-get widget :custom-state)))
+(cond ((memq state '(invalid modified))
+	   (error "There are unset changes"))
+	  ((eq state 'hidden)
+	   (widget-put widget :custom-state 'unknown))
+	  (t
+	   (widget-put widget :custom-state 'hidden)))
+(custom-redraw widget)))
 ;;; The `custom-variable' Widget.
 (defface custom-variable-sample-face '((t (:underline t)))
 "Face used for unpushable variable tags."
 :group 'custom-faces)
 		   (and (not (get symbol 'factory-value))
 			(custom-guess-type symbol))
 		   'sexp))
 	 (options (get symbol 'custom-options))
 	 (tmp (if (listp type)
-		  (copy-list type)
+		  (copy-sequence type)
 		(list type))))
 (when options
 (widget-put tmp :options options))
 tmp))
 	 (state (widget-get widget :custom-state))
 	 (symbol (widget-get widget :value))
 	 (tag (widget-get widget :tag))
 	 (type (custom-variable-type symbol))
 	 (conv (widget-convert type))
+	 (get (or (get symbol 'custom-get) 'default-value))
 	 (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)
 	  ((custom-show type value)
 	   (setq state 'unknown))
 	   (let* ((value (cond ((get symbol 'saved-value)
 				(car (get symbol 'saved-value)))
 			       ((get symbol 'factory-value)
 				(car (get symbol 'factory-value)))
 			       ((default-boundp symbol)
-				(custom-quote (default-value symbol)))
+				(custom-quote (funcall get symbol)))
 			       (t
 				(custom-quote (widget-get conv :value))))))
 	     (push (widget-create-child-and-convert
 		    widget 'sexp
 		    :button-face 'custom-variable-button-face
 (widget-put widget :children children)))
 (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))
 		       (if (condition-case nil
 			       (equal value (eval (car tmp)))
 			 'changed))
 		      (t 'rogue))))
 (widget-put widget :custom-state state)))
 (defvar custom-variable-menu
-'(("Edit" . custom-variable-edit)
+'(("Hide" custom-toggle-hide
-("Edit Lisp" . custom-variable-edit-lisp)
+(lambda (widget)
-("Set" . custom-variable-set)
+(not (memq (widget-get widget :custom-state) '(modified invalid)))))
-("Save" . custom-variable-save)
+("Edit" custom-variable-edit
-("Reset to Current" . custom-redraw)
+(lambda (widget)
-("Reset to Saved" . custom-variable-reset-saved)
+(not (eq (widget-get widget :custom-form) 'edit))))
-("Reset to Factory Settings" . custom-variable-reset-factory))
+("Edit Lisp" custom-variable-edit-lisp
+(lambda (widget)
+(not (eq (widget-get widget :custom-form) 'lisp))))
+("Set" custom-variable-set
+(lambda (widget)
+(eq (widget-get widget :custom-state) 'modified)))
+("Save" custom-variable-save
+(lambda (widget)
+(memq (widget-get widget :custom-state) '(modified set changed rogue))))
+("Reset to Current" custom-redraw
+(lambda (widget)
+(and (default-boundp (widget-value widget))
+	    (memq (widget-get widget :custom-state) '(modified 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 Factory Settings" custom-variable-reset-factory
+(lambda (widget)
+(and (get (widget-value widget) 'factory-value)
+	    (memq (widget-get widget :custom-state)
+		  '(modified set changed saved rogue))))))
 "Alist of actions for the `custom-variable' widget.
-The key is a string containing the name of the action, the value is a
+Each entry has the form (NAME ACTION FILTER) where NAME is the name of
-lisp function taking the widget as an element which will be called
+the menu entry, ACTION is the function to call on the widget when the
-when the action is chosen.")
+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
+(custom-toggle-hide widget)
-	(widget-put widget :custom-state 'unknown)
+(unless (eq (widget-get widget :custom-state) 'modified)
-	(custom-redraw widget))
+(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
+				  (custom-menu-filter custom-variable-menu
+						      widget)
 				  event)))
 (if answer
 	  (funcall answer widget)))))
 (defun custom-variable-edit (widget)
 (widget-put widget :custom-form 'lisp)
 (custom-redraw widget))
 (defun custom-variable-set (widget)
 "Set the current value for the variable being edited by WIDGET."
-(let ((form (widget-get widget :custom-form))
+(let* ((form (widget-get widget :custom-form))
-	(state (widget-get widget :custom-state))
+	 (state (widget-get widget :custom-state))
-	(child (car (widget-get widget :children)))
+	 (child (car (widget-get widget :children)))
-	(symbol (widget-value widget))
+	 (symbol (widget-value widget))
-	val)
+	 (set (or (get symbol 'custom-set) 'set-default))
+	  val)
 (cond ((eq state 'hidden)
 	   (error "Cannot set hidden variable."))
 	  ((setq val (widget-apply child :validate))
 	   (goto-char (widget-get val :from))
 	   (error "%s" (widget-get val :error)))
 	  ((eq form 'lisp)
-	   (set-default symbol (eval (setq val (widget-value child))))
+	   (funcall set symbol (eval (setq val (widget-value child))))
 	   (put symbol 'customized-value (list val)))
 	  (t
-	   (set-default symbol (setq val (widget-value child)))
+	   (funcall set symbol (setq val (widget-value child)))
 	   (put symbol 'customized-value (list (custom-quote val)))))
 (custom-variable-state-set widget)
 (custom-redraw-magic widget)))
 (defun custom-variable-save (widget)
 "Set the default value for the variable being edited by WIDGET."
-(let ((form (widget-get widget :custom-form))
+(let* ((form (widget-get widget :custom-form))
-	(state (widget-get widget :custom-state))
+	 (state (widget-get widget :custom-state))
-	(child (car (widget-get widget :children)))
+	 (child (car (widget-get widget :children)))
-	(symbol (widget-value widget))
+	 (symbol (widget-value widget))
-	val)
+	 (set (or (get symbol 'custom-set) 'set-default))
+	 val)
 (cond ((eq state 'hidden)
 	   (error "Cannot set hidden variable."))
 	  ((setq val (widget-apply child :validate))
 	   (goto-char (widget-get val :from))
 	   (error "%s" (widget-get val :error)))
 	  ((eq form 'lisp)
 	   (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)
 (custom-redraw-magic widget)))
 (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)))
+(let* ((symbol (widget-value widget))
+	 (set (or (get symbol 'custom-set) 'set-default)))
 (if (get symbol 'factory-value)
-	(set-default symbol (eval (car (get symbol 'factory-value))))
+	(funcall set symbol (eval (car (get symbol 'factory-value))))
 (error "No factory default for %S" symbol))
 (put symbol 'customized-value nil)
 (when (get symbol 'saved-value)
 (put symbol 'saved-value nil)
 (custom-save-all))
 "A display specification that doesn't match the selected display."
 :match 'custom-display-unselected-match)
 (defun custom-display-unselected-match (widget value)
 "Non-nil if VALUE is an unselected display specification."
-(and (listp value)
+(not (face-spec-set-match-display value (selected-frame))))
-(eq (length value) 2)
-(not (custom-display-match-frame value (selected-frame)))))
 (define-widget 'custom-face-selected 'group
 "Edit the attributes of the selected display in a face specification."
 :args '((repeat :format ""
 		  :inline t
 (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)
+		     (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))
 (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)
+'(("Hide" custom-toggle-hide
-("Edit All" . custom-face-edit-all)
+(lambda (widget)
-("Edit Lisp" . custom-face-edit-lisp)
+(not (memq (widget-get widget :custom-state) '(modified invalid)))))
-("Set" . custom-face-set)
+("Edit Selected" custom-face-edit-selected
-("Save" . custom-face-save)
+(lambda (widget)
-("Reset to Saved" . custom-face-reset-saved)
+(not (eq (widget-get widget :custom-form) 'selected))))
-("Reset to Factory Setting" . custom-face-reset-factory))
+("Edit All" custom-face-edit-all
+(lambda (widget)
+(not (eq (widget-get widget :custom-form) 'all))))
+("Edit Lisp" custom-face-edit-lisp
+(lambda (widget)
+(not (eq (widget-get widget :custom-form) 'lisp))))
+("Set" custom-face-set)
+("Save" custom-face-save)
+("Reset to Saved" custom-face-reset-saved
+(lambda (widget)
+(get (widget-value widget) 'saved-face)))
+("Reset to Factory Setting" custom-face-reset-factory
+(lambda (widget)
+(get (widget-value widget) 'face-defface-spec))))
 "Alist of actions for the `custom-face' widget.
-The key is a string containing the name of the action, the value is a
+Each entry has the form (NAME ACTION FILTER) where NAME is the name of
-lisp function taking the widget as an element which will be called
+the menu entry, ACTION is the function to call on the widget when the
-when the action is chosen.")
+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."
 (widget-put widget :custom-state 'unknown)
 (widget-put widget :custom-form 'selected)
 (let ((symbol (widget-value widget)))
 (widget-put widget :custom-state (cond ((get symbol 'customized-face)
 					    'set)
 					   ((get symbol 'saved-face)
 					    'saved)
-					   ((get symbol 'factory-face)
+					   ((get symbol 'face-defface-spec)
 					    'factory)
 					   (t
 					    'rogue)))))
 (defun custom-face-action (widget &optional event)
 "Show the menu for `custom-face' WIDGET.
 Optional EVENT is the location for the menu."
 (if (eq (widget-get widget :custom-state) 'hidden)
-(progn
+(custom-toggle-hide widget)
-	(widget-put widget :custom-state 'unknown)
-	(custom-redraw widget))
 (let* ((completion-ignore-case t)
 	   (symbol (widget-get widget :value))
 	   (answer (widget-choose (custom-unlispify-tag-name symbol)
-				  custom-face-menu event)))
+				  (custom-menu-filter custom-face-menu
+						      widget)
+				  event)))
 (if answer
 	  (funcall answer widget)))))
 (defun custom-face-set (widget)
 "Make the face attributes in WIDGET take effect."
 (let* ((symbol (widget-value widget))
 	 (child (car (widget-get widget :children)))
 	 (value (widget-value child)))
 (put symbol 'customized-face value)
-(when (fboundp 'copy-face)
-(copy-face 'custom-face-empty symbol))
 (custom-face-display-set symbol value)
 (custom-face-state-set widget)
 (custom-redraw-magic widget)))
 (defun custom-face-save (widget)
 "Make the face attributes in WIDGET default."
 (let* ((symbol (widget-value widget))
 	 (child (car (widget-get widget :children)))
 	 (value (widget-value child)))
-(when (fboundp 'copy-face)
-(copy-face 'custom-face-empty symbol))
 (custom-face-display-set symbol value)
 (put symbol 'saved-face value)
 (put symbol 'customized-face nil)
 (custom-face-state-set widget)
 (custom-redraw-magic widget)))
 	 (child (car (widget-get widget :children)))
 	 (value (get symbol 'saved-face)))
 (unless value
 (error "No saved value for this face"))
 (put symbol 'customized-face nil)
-(when (fboundp 'copy-face)
-(copy-face 'custom-face-empty symbol))
 (custom-face-display-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."
 (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"))
 (put symbol 'customized-face nil)
 (when (get symbol 'saved-face)
 (put symbol 'saved-face nil)
 (custom-save-all))
-(when (fboundp 'copy-face)
-(copy-face 'custom-face-empty symbol))
 (custom-face-display-set symbol value)
 (widget-value-set child value)
 (custom-face-state-set widget)
 (custom-redraw-magic widget)))
 ;;; The `face' Widget.
 (define-widget 'face 'default
 "Select and customize a face."
-:convert-widget 'widget-item-convert-widget
+:convert-widget 'widget-value-convert-widget
 :format "%[%t%]: %v"
 :tag "Face"
 :value 'default
 :value-create 'widget-face-value-create
 :value-delete 'widget-face-value-delete
-:value-get 'widget-item-value-get
+:value-get 'widget-value-value-get
-:validate 'widget-editable-list-validate
+: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.
 	(widget-put widget :children children)
 	(custom-group-state-update widget)
 	(message "Creating group... done")))))
 (defvar custom-group-menu
-'(("Set" . custom-group-set)
+'(("Hide" custom-toggle-hide
-("Save" . custom-group-save)
+(lambda (widget)
-("Reset to Current" . custom-group-reset-current)
+(not (memq (widget-get widget :custom-state) '(modified invalid)))))
-("Reset to Saved" . custom-group-reset-saved)
+("Set" custom-group-set
-("Reset to Factory" . custom-group-reset-factory))
+(lambda (widget)
+(eq (widget-get widget :custom-state) 'modified)))
+("Save" custom-group-save
+(lambda (widget)
+(memq (widget-get widget :custom-state) '(modified set))))
+("Reset to Current" custom-group-reset-current
+(lambda (widget)
+(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 Factory" custom-group-reset-factory
+(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
+Each entry has the form (NAME ACTION FILTER) where NAME is the name of
-lisp function taking the widget as an element which will be called
+the menu entry, ACTION is the function to call on the widget when the
-when the action is chosen.")
+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
+(custom-toggle-hide widget)
-	(widget-put widget :custom-state 'unknown)
-	(custom-redraw widget))
 (let* ((completion-ignore-case t)
 	   (answer (widget-choose (custom-unlispify-tag-name
 				   (widget-get widget :value))
-				  custom-group-menu
+				  (custom-menu-filter custom-group-menu
+						      widget)
 				  event)))
 (if answer
 	  (funcall answer widget)))))
 (defun custom-group-set (widget)
 (let ((standard-output (current-buffer)))
 (unless (bolp)
 	(princ "\n"))
 (princ "(custom-set-variables")
 (mapatoms (lambda (symbol)
-		  (let ((value (get symbol 'saved-value)))
+		  (let ((value (get symbol 'saved-value))
+			(requests (get symbol 'custom-requests))
+			(now (not (or (get symbol 'factory-value)
+				      (and (not (boundp symbol))
+					   (not (get symbol 'force-value)))))))
 		    (when value
 		      (princ "\n '(")
 		      (princ symbol)
 		      (princ " ")
 		      (prin1 (car value))
-		      (if (or (get symbol 'factory-value)
+		      (cond (requests
-			      (and (not (boundp symbol))
+			     (if now
-				   (not (get symbol 'force-value))))
+				 (princ " t ")
-			  (princ ")")
+			       (princ " nil "))
-			(princ " t)"))))))
+			     (prin1 requests)
+			     (princ ")"))
+			    (now
+			     (princ " t)"))
+			    (t
+			     (princ ")")))))))
 (princ ")")
 (unless (looking-at "\n")
 	(princ "\n")))))
 (defun custom-save-faces ()
 (let ((value (get 'default 'saved-face)))
 	;; The default face must be first, since it affects the others.
 	(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 ")")
 	    (princ " t)"))))
 (mapatoms (lambda (symbol)
 			       value)
 		      (princ "\n '(")
 		      (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 ")")
 			(princ " t)"))))))
 (princ ")")
 (unless (looking-at "\n")
 	(princ "\n")))))
+;;;###autoload
+(defun custom-save-customized ()
+"Save all user options which have been set in this session."
+(interactive)
+(mapatoms (lambda (symbol)
+	      (let ((face (get symbol 'customized-face))
+		    (value (get symbol 'customized-value)))
+		(when face
+		  (put symbol 'saved-face face)
+		  (put symbol 'customized-face nil))
+		(when value
+		  (put symbol 'saved-value value)
+		  (put symbol 'customized-value nil)))))
+;; We really should update all custom buffers here.
+(custom-save-all))
 ;;;###autoload
 (defun custom-save-all ()
 "Save all customizations in `custom-file'."
 (custom-save-variables)
 :group 'customize))
 (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)
 "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
 (let ((type (get symbol 'custom-type)))
 (unless (listp type)
 (setq type (list type)))
 (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
+				   `(customize-variable ',symbol)
-				     '((,symbol custom-variable)))
 				   ':style 'toggle
 				   ':selected symbol)))
 (if (string-match "XEmacs" emacs-version)
 ;; XEmacs can create menus dynamically.
 ;;;###autoload
 (defun custom-menu-create (symbol)
 "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 ',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
 (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."
+"Menu used to customize customization buffers."
 (customize-menu-create 'customize))
 (easy-menu-define custom-mode-menu
 custom-mode-map
 "Menu used in customization buffers."

Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-edit.el @ 149:538048ae2ab8 r20-3b1