comparison lisp/cus-edit.el @ 28130:e419308bcc0c

Doc fixes. (customize-set-variable, customize-save-variable): Rename args for doc. (custom-variable-tag-face, custom-face-tag-face) (custom-group-tag-face-1, custom-group-tag-face): Modify from style which user identify as hyperlink. (hook): Don't add undefined functions to the hook. (debug-ignored-errors): Transfer message from bindings.el.

28129:25e19c5c91f8

;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages.
;;
;; Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: help, faces
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ (probably obsolete)

;; 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

;;; Utilities.

(defun custom-quote (sexp)
  "Quote SEXP iff it is not self quoting."
  (if (or (memq sexp '(t nil))
	  (and (symbolp sexp)
	       (eq (aref (symbol-name sexp) 0) ?:))
	  (and (listp sexp)
	       (memq (car sexp) '(lambda)))
	  (stringp sexp)
	  (numberp sexp)
	  (vectorp sexp)

    (nreverse result)))

;;; Unlispify.

(defvar custom-prefix-list nil
  "List of prefixes that should be ignored by `custom-unlispify'")

(defcustom custom-unlispify-menu-entries t
  "Display menu entries as words instead of symbols if non nil."
  :group 'custom-menu
  :type 'boolean)

  "Non-nil means remove group prefixes from option names in buffer."
  :group 'custom-menu
  :type 'boolean)

(defun custom-unlispify-menu-entry (symbol &optional no-suffix)
  "Convert symbol into a menu entry."
  (cond ((not custom-unlispify-menu-entries)
	 (symbol-name symbol))
	((get symbol 'custom-tag)
	 (if no-suffix
	     (get symbol 'custom-tag)

  "Display tag names as words instead of symbols if non nil."
  :group 'custom-buffer
  :type 'boolean)

(defun custom-unlispify-tag-name (symbol)
  "Convert symbol into a menu entry."
  (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
    (custom-unlispify-menu-entry symbol t)))

(defun custom-prefix-add (symbol prefixes)
  ;; Addd SYMBOL to list of ignored PREFIXES.
  (cons (or (get symbol 'custom-prefix)
	    (concat (symbol-name symbol) "-"))
	prefixes))

;;; Guess.

  '(("Current" . Custom-reset-current)
    ("Saved" . Custom-reset-saved)
    ("Erase Customization (use 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.")

(defun custom-reset (event)
  "Select item from reset menu."
  (let* ((completion-ignore-case t)

 	 (put var 'variable-comment nil))
 	(comment
 	 (put var 'variable-comment comment))))

;;;###autoload
(defun customize-set-variable (var val &optional comment)
  "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.

If given a prefix (or a COMMENT argument), also prompt for a comment."
  (interactive (custom-prompt-variable "Set variable: "
				       "Set customized value for %s to: "
				       current-prefix-arg))
  (funcall (or (get var 'custom-set) 'set-default) var val)
  (put var 'customized-value (list (custom-quote val)))
  (cond ((string= comment "")
 	 (put var 'variable-comment nil)
 	 (put var 'customized-variable-comment nil))
 	(comment
 	 (put var 'variable-comment comment)
 	 (put var 'customized-variable-comment comment))))

;;;###autoload
(defun customize-save-variable (var val &optional comment)
  "Set the default for VARIABLE to VALUE, and save it for future sessions.
If VARIABLE has a `custom-set' property, that is used for setting
VARIABLE, otherwise `set-default' is used.

The `customized-value' property of the VARIABLE will be set to a list

If given a prefix (or a COMMENT argument), also prompt for a comment."
  (interactive (custom-prompt-variable "Set and ave variable: "
				       "Set and save value for %s as: "
				       current-prefix-arg))
  (funcall (or (get var 'custom-set) 'set-default) var val)
  (put var 'saved-value (list (custom-quote val)))
  (cond ((string= comment "")
 	 (put var 'variable-comment nil)
 	 (put var 'saved-variable-comment nil))
 	(comment
 	 (put var 'variable-comment comment)

			  (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: "
				      obarray 'custom-facep t)))
  (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
      ()
    (if (stringp symbol)

  (not (eq (widget-get (widget-get (widget-get widget :parent) :parent)
		       :custom-state)
	   'hidden)))

(defun custom-magic-value-create (widget)
  ;; Create compact status report for WIDGET.
  (let* ((parent (widget-get widget :parent))
	 (state (widget-get parent :custom-state))
	 (hidden (eq state 'hidden))
	 (entry (assq state custom-magic-alist))
	 (magic (nth 1 entry))

  :value-get 'widget-value-value-get
  :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)))
    (when args
      (widget-put widget :value (widget-apply widget
					      :value-to-internal (car args)))
      (widget-put widget :tag (custom-unlispify-tag-name (car args)))

    (and (equal "" val)
	 (not (widget-get widget :comment-shown)))))

;;; The `custom-variable' Widget.

(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."

  (widget-put widget :custom-state 'unknown)
  (widget-put widget :custom-form 'edit)
  (custom-redraw widget))

(defun custom-variable-edit-lisp (widget)
  "Edit the lisp representation of the value of WIDGET."
  (widget-put widget :custom-state 'unknown)
  (widget-put widget :custom-form 'lisp)
  (custom-redraw widget))

(defun custom-variable-set (widget)

Match frames with dark backgrounds.")
					   dark)))))))

;;; The `custom-face' Widget.

(defface custom-face-tag-face '((t (:underline t)))
  "Face used for face tags."
  :group 'custom-faces)

(defcustom custom-face-default-form 'selected
  "Default form of displaying face definition."

  (widget-put widget :custom-state 'unknown)
  (widget-put widget :custom-form 'all)
  (custom-redraw widget))

(defun custom-face-edit-lisp (widget)
  "Edit the lisp representation of the value of WIDGET."
  (widget-put widget :custom-state 'unknown)
  (widget-put widget :custom-form 'lisp)
  (custom-redraw widget))

(defun custom-face-state-set (widget)

  :validate 'widget-children-validate
  :action 'widget-face-action
  :match '(lambda (widget value) (symbolp value)))

(defun widget-face-value-create (widget)
  ;; Create a `custom-face' child.
  (let* ((symbol (widget-value widget))
	 (custom-buffer-style 'face)
	 (child (widget-create-child-and-convert
		 widget 'custom-face
		 :custom-level nil

    (custom-magic-reset child)
    (setq custom-options (cons child custom-options))
    (widget-put widget :children (list child))))

(defun widget-face-value-delete (widget)
  ;; Remove the child from the options.
  (let ((child (car (widget-get widget :children))))
    (setq custom-options (delq child custom-options))
    (widget-children-value-delete widget)))

(defvar face-history nil

			   (list value)
			 value))
  :match (lambda (widget value)
	   (or (symbolp value)
	       (widget-group-match widget value)))
  :convert-widget 'custom-hook-convert-widget
  :tag "Hook")

(defun custom-hook-convert-widget (widget)
  ;; Handle `:options'.

and so forth.  The remaining group tags are shown with
`custom-group-tag-face'."
  :type '(repeat face)
  :group 'custom-faces)

(defface custom-group-tag-face-1 '((((class color)
				     (background dark))
				    (:foreground "pink" :underline t))
				   (((class color)
				     (background light))
				    (:foreground "red" :underline t))
				   (t (:underline t)))
  "Face used for group tags.")

(defface custom-group-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 low level group tags."
  :group 'custom-faces)

(define-widget 'custom-group 'custom
  "Customize group."

    (set (make-local-variable 'widget-link-suffix) ""))
  (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)

;;; cus-edit.el ends here

28130:e419308bcc0c

;;; cus-edit.el --- Tools for customizing Emacs and Lisp packages.
;;
;; Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: help, faces

;; 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

;;; Utilities.

(defun custom-quote (sexp)
  "Quote SEXP iff it is not self quoting."
  (if (or (memq sexp '(t nil))
	  (keywordp sexp)
	  (and (listp sexp)
	       (memq (car sexp) '(lambda)))
	  (stringp sexp)
	  (numberp sexp)
	  (vectorp sexp)

    (nreverse result)))

;;; Unlispify.

(defvar custom-prefix-list nil
  "List of prefixes that should be ignored by `custom-unlispify'.")

(defcustom custom-unlispify-menu-entries t
  "Display menu entries as words instead of symbols if non nil."
  :group 'custom-menu
  :type 'boolean)

  "Non-nil means remove group prefixes from option names in buffer."
  :group 'custom-menu
  :type 'boolean)

(defun custom-unlispify-menu-entry (symbol &optional no-suffix)
  "Convert SYMBOL into a menu entry."
  (cond ((not custom-unlispify-menu-entries)
	 (symbol-name symbol))
	((get symbol 'custom-tag)
	 (if no-suffix
	     (get symbol 'custom-tag)

  "Display tag names as words instead of symbols if non nil."
  :group 'custom-buffer
  :type 'boolean)

(defun custom-unlispify-tag-name (symbol)
  "Convert SYMBOL into a menu entry."
  (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
    (custom-unlispify-menu-entry symbol t)))

(defun custom-prefix-add (symbol prefixes)
  "Add SYMBOL to list of ignored PREFIXES."
  (cons (or (get symbol 'custom-prefix)
	    (concat (symbol-name symbol) "-"))
	prefixes))

;;; Guess.

  '(("Current" . Custom-reset-current)
    ("Saved" . Custom-reset-saved)
    ("Erase Customization (use 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.")

(defun custom-reset (event)
  "Select item from reset menu."
  (let* ((completion-ignore-case t)

 	 (put var 'variable-comment nil))
 	(comment
 	 (put var 'variable-comment comment))))

;;;###autoload
(defun customize-set-variable (variable value &optional comment)
  "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.

If given a prefix (or a COMMENT argument), also prompt for a comment."
  (interactive (custom-prompt-variable "Set variable: "
				       "Set customized value for %s to: "
				       current-prefix-arg))
  (funcall (or (get variable 'custom-set) 'set-default) variable value)
  (put variable 'customized-value (list (custom-quote value)))
  (cond ((string= comment "")
 	 (put variable 'variable-comment nil)
 	 (put variable 'customized-variable-comment nil))
 	(comment
 	 (put variable 'variable-comment comment)
 	 (put variable 'customized-variable-comment comment))))

;;;###autoload
(defun customize-save-variable (var value &optional comment)
  "Set the default for VARIABLE to VALUE, and save it for future sessions.
If VARIABLE has a `custom-set' property, that is used for setting
VARIABLE, otherwise `set-default' is used.

The `customized-value' property of the VARIABLE will be set to a list

If given a prefix (or a COMMENT argument), also prompt for a comment."
  (interactive (custom-prompt-variable "Set and ave variable: "
				       "Set and save value for %s as: "
				       current-prefix-arg))
  (funcall (or (get var 'custom-set) 'set-default) var value)
  (put var 'saved-value (list (custom-quote value)))
  (cond ((string= comment "")
 	 (put var 'variable-comment nil)
 	 (put var 'saved-variable-comment nil))
 	(comment
 	 (put var 'variable-comment comment)

			  (format "*Customize Face: %s*"
				  (custom-unlispify-tag-name symbol)))))

;;;###autoload
(defun customize-face-other-window (&optional symbol)
  "Show customization buffer for face SYMBOL in other window."
  (interactive (list (completing-read "Customize face: "
				      obarray 'custom-facep t)))
  (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
      ()
    (if (stringp symbol)

  (not (eq (widget-get (widget-get (widget-get widget :parent) :parent)
		       :custom-state)
	   'hidden)))

(defun custom-magic-value-create (widget)
  "Create compact status report for WIDGET."
  (let* ((parent (widget-get widget :parent))
	 (state (widget-get parent :custom-state))
	 (hidden (eq state 'hidden))
	 (entry (assq state custom-magic-alist))
	 (magic (nth 1 entry))

  :value-get 'widget-value-value-get
  :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)))
    (when args
      (widget-put widget :value (widget-apply widget
					      :value-to-internal (car args)))
      (widget-put widget :tag (custom-unlispify-tag-name (car args)))

    (and (equal "" val)
	 (not (widget-get widget :comment-shown)))))

;;; The `custom-variable' Widget.

;; When this was underlined blue, users confused it with a
;; Mosaic-style hyperlink...
(defface custom-variable-tag-face `((((class color)
				      (background dark))
				     (:foreground "light blue"
				      :bold t
				      :family "helv"
				      :height ,(floor (face-attribute
						       'default :height) 0.9)))
				    (((class color)
				      (background light))
				     (:foreground "blue" :family "helv"
				      :bold t
				      :height ,(floor (face-attribute
						       'default :height) 0.9)))
				    (t (:bold 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."

  (widget-put widget :custom-state 'unknown)
  (widget-put widget :custom-form 'edit)
  (custom-redraw widget))

(defun custom-variable-edit-lisp (widget)
  "Edit the Lisp representation of the value of WIDGET."
  (widget-put widget :custom-state 'unknown)
  (widget-put widget :custom-form 'lisp)
  (custom-redraw widget))

(defun custom-variable-set (widget)

Match frames with dark backgrounds.")
					   dark)))))))

;;; The `custom-face' Widget.

(defface custom-face-tag-face `((t (:bold t :family "helv"
				    :height ,(floor (face-attribute
						     'default :height) 0.9))))
  "Face used for face tags."
  :group 'custom-faces)

(defcustom custom-face-default-form 'selected
  "Default form of displaying face definition."

  (widget-put widget :custom-state 'unknown)
  (widget-put widget :custom-form 'all)
  (custom-redraw widget))

(defun custom-face-edit-lisp (widget)
  "Edit the Lisp representation of the value of WIDGET."
  (widget-put widget :custom-state 'unknown)
  (widget-put widget :custom-form 'lisp)
  (custom-redraw widget))

(defun custom-face-state-set (widget)

  :validate 'widget-children-validate
  :action 'widget-face-action
  :match '(lambda (widget value) (symbolp value)))

(defun widget-face-value-create (widget)
  "Create a `custom-face' child."
  (let* ((symbol (widget-value widget))
	 (custom-buffer-style 'face)
	 (child (widget-create-child-and-convert
		 widget 'custom-face
		 :custom-level nil

    (custom-magic-reset child)
    (setq custom-options (cons child custom-options))
    (widget-put widget :children (list child))))

(defun widget-face-value-delete (widget)
  "Remove the child from the options."
  (let ((child (car (widget-get widget :children))))
    (setq custom-options (delq child custom-options))
    (widget-children-value-delete widget)))

(defvar face-history nil

			   (list value)
			 value))
  :match (lambda (widget value)
	   (or (symbolp value)
	       (widget-group-match widget value)))
  ;; Avoid adding undefined functions to the hook, especially for
  ;; things like `find-file-hook' or even more basic ones, to avoid
  ;; chaos.
  :set (lambda (symbol value)
	 (mapc (lambda (elt)
		 (if (fboundp elt)
		     (add-hook symbol elt)))
	       value))
  :convert-widget 'custom-hook-convert-widget
  :tag "Hook")

(defun custom-hook-convert-widget (widget)
  ;; Handle `:options'.

and so forth.  The remaining group tags are shown with
`custom-group-tag-face'."
  :type '(repeat face)
  :group 'custom-faces)

(defface custom-group-tag-face-1 `((((class color)
				     (background dark))
				    (:foreground "pink" :family "helv"
				     :height ,(floor (face-attribute
						      'default :height) 0.9)
				     :bold t))
				   (((class color)
				     (background light))
				    (:foreground "red" :bold t
				     :height ,(floor (face-attribute
						      'default :height) 0.9)))
				   (t (:bold t)))
  "Face used for group tags.")

(defface custom-group-tag-face `((((class color)
				   (background dark))
				  (:foreground "light blue" :bold t
				   :height ,(floor (face-attribute
						   'default :height) 0.9)))
				 (((class color)
				   (background light))
				  (:foreground "blue" :bold t
				   :height ,(floor (face-attribute
						    'default :height) 0.9)))
				 (t (:bold t)))
  "Face used for low level group tags."
  :group 'custom-faces)

(define-widget 'custom-group 'custom
  "Customize group."

    (set (make-local-variable 'widget-link-suffix) ""))
  (make-local-hook 'widget-edit-functions)
  (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)
  (run-hooks 'custom-mode-hook))

(add-to-list
 'debug-ignored-errors
 "^No user options have changed defaults in recent Emacs versions$")

;;; The End.

(provide 'cus-edit)

;;; cus-edit.el ends here