;;; custom.el -- Tools for declaring and initializing options.
;;
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 0.9
+;; Version: 1.55
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
;;
;; This file only contain the code needed to declare and initialize
;; user options. The code to customize options is autoloaded from
-;; `custom-edit.el'.
+;; `cus-edit.el'.
+
+;; The code implementing face declarations is in `cus-face.el'
;;; Code:
(require 'widget)
-(let ((keywords '(:type :group)))
- (while keywords
- (or (boundp (car keywords))
- (set (car keywords) (car keywords)))
- (setq keywords (cdr keywords))))
+(define-widget-keywords :prefix :tag :load :link :options :type :group)
;; These autoloads should be deleted when the file is added to Emacs
-(autoload 'customize "custom-edit" nil t)
-(autoload 'customize-variable "custom-edit" nil t)
-(autoload 'customize-face "custom-edit" nil t)
-(autoload 'customize-apropos "custom-edit" nil t)
-
-;;; Face Utilities.
-
-(make-face 'custom-face-empty)
-
-(defun custom-face-display-set (face spec &optional frame)
- "Set FACE to the attributes to the first matching entry in SPEC.
-Iff optional FRAME is non-nil, set it for that frame only.
-See `defface' for information about SPEC."
- (make-face face)
- (copy-face 'custom-face-empty face)
- (while spec
- (let* ((entry (car spec))
- (display (nth 0 entry))
- (atts (nth 1 entry)))
- (setq spec (cdr spec))
- (when (custom-display-match-frame display frame)
- (apply 'custom-face-attribites-set face frame atts)
- (setq spec nil)))))
-
-(defun custom-display-match-frame (display frame)
- "Non-nil iff DISPLAY matches FRAME.
-If FRAME is nil, the current FRAME is used."
- (unless frame
- (setq frame (selected-frame)))
- (if (eq display t)
- t
- (let ((match t)
- (pars (frame-parameters frame)))
- (while (and display match)
- (let* ((entry (car display))
- (req (car entry))
- (options (cdr entry)))
- (setq display (cdr display))
- (cond ((eq req 'type)
- (setq match (memq window-system options)))
- ((eq req 'class)
- (let ((class (cdr (assq 'display-type pars))))
- (setq match (memq class options))))
- ((eq req 'background)
- (let ((background (cdr (assq 'background-mode pars))))
- (setq match (memq background options))))
- (t
- (error "Unknown req `%S' with options `%S'" req options)))))
- match)))
-
-(defvar custom-face-attributes
- '((:bold (toggle :format "Bold: %v") custom-set-face-bold)
- (:italic (toggle :format "Italic: %v") custom-set-face-italic)
- (:underline
- (toggle :format "Underline: %v") set-face-underline-p)
- (:foreground (color :tag "Foreground") set-face-foreground)
- (:background (color :tag "Background") set-face-background)
- (:stipple (field :format "Stipple: %v") set-face-stipple))
- "Alist of face attributes.
-
-The elements are of the form (KEY TYPE SET) where KEY is a symbol
-identifying the attribute, TYPE is a widget type for editing the
-attibute, SET is a function for setting the attribute value.
-
-The SET function should take three arguments, the face to modify, the
-value of the attribute, and optionally the frame where the face should
-be changed.")
-
-(defun custom-face-attribites-set (face frame &rest atts)
- "For FACE on FRAME set the attributes [KEYWORD VALUE]....
-Each keyword should be listed in `custom-face-attributes'.
-
-If FRAME is nil, set the default face."
- (while atts
- (let* ((name (nth 0 atts))
- (value (nth 1 atts))
- (fun (nth 2 (assq name custom-face-attributes))))
- (setq atts (cdr (cdr atts)))
- (funcall fun face value))))
-
-(defun custom-set-face-bold (face value &optional frame)
- "Set the bold property of FACE to VALUE."
- (condition-case nil
- (if value
- (make-face-bold face frame)
- (make-face-unbold face frame))
- (error nil)))
-
-(defun custom-set-face-italic (face value &optional frame)
- "Set the italic property of FACE to VALUE."
- (condition-case nil
- (if value
- (make-face-italic face frame)
- (make-face-unitalic face frame))
- (error nil)))
-
-;;;###autoload
-(defun custom-initialize-faces (&optional frame)
- "Initialize all custom faces for FRAME.
-If FRAME is nil or omitted, initialize them for all frames."
- (mapatoms (lambda (symbol)
- (let ((spec (or (get symbol 'saved-face)
- (get symbol 'factory-face))))
- (when spec
- (custom-face-display-set symbol spec frame))))))
+
+(unless (fboundp 'load-gc)
+ ;; From cus-edit.el
+ (autoload 'customize "cus-edit" nil t)
+ (autoload 'customize-variable "cus-edit" nil t)
+ (autoload 'customize-face "cus-edit" nil t)
+ (autoload 'customize-apropos "cus-edit" nil t)
+ (autoload 'customize-customized "cus-edit" nil t)
+ (autoload 'custom-buffer-create "cus-edit")
+ (autoload 'custom-menu-update "cus-edit")
+ (autoload 'custom-make-dependencies "cus-edit")
+ ;; From cus-face.el
+ (autoload 'custom-declare-face "cus-face")
+ (autoload 'custom-set-faces "cus-face"))
;;; The `defcustom' Macro.
-;;;###autoload
-(defun custom-declare-variable (symbol value &rest args)
- "Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments."
- (unless (default-boundp symbol)
- (set-default symbol (eval value)))
+(defun custom-declare-variable (symbol value doc &rest args)
+ "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
+ (unless (and (default-boundp symbol)
+ (not (get symbol 'saved-value)))
+ (set-default symbol (if (get symbol 'saved-value)
+ (eval (car (get symbol 'saved-value)))
+ (eval value))))
(put symbol 'factory-value (list value))
- (while args
+ (when doc
+ (put symbol 'variable-documentation doc))
+ (while args
(let ((arg (car args)))
(setq args (cdr args))
- (cond ((symbolp arg)
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" keyword))
- (setq args (cdr args))
- (cond ((eq keyword :type)
- (put symbol 'custom-type value))
- ((eq keyword :group)
- (custom-add-to-group value symbol 'custom-variable))
- (t
- (error "Unknown keyword %s" symbol)))))
- ((stringp arg)
- (put symbol 'variable-documentation arg)
- (when args
- (error "Junk at end of args %s" args)))
- (t
- (error "Junk in args %S"))))))
-
-;;;###autoload
-(defmacro defcustom (symbol value &rest args)
+ (unless (symbolp arg)
+ (error "Junk in args %S" args))
+ (let ((keyword arg)
+ (value (car args)))
+ (unless args
+ (error "Keyword %s is missing an argument" keyword))
+ (setq args (cdr args))
+ (cond ((eq keyword :type)
+ (put symbol 'custom-type value))
+ ((eq keyword :options)
+ (if (get symbol 'custom-options)
+ ;; Slow safe code to avoid duplicates.
+ (mapcar (lambda (option)
+ (custom-add-option symbol option))
+ value)
+ ;; Fast code for the common case.
+ (put symbol 'custom-options (copy-list value))))
+ (t
+ (custom-handle-keyword symbol keyword value
+ 'custom-variable))))))
+ (run-hooks 'custom-define-hook)
+ symbol)
+
+(defmacro defcustom (symbol value doc &rest args)
"Declare SYMBOL as a customizable variable that defaults to VALUE.
+DOC is the variable documentation.
+
Neither SYMBOL nor VALUE needs to be quoted.
If SYMBOL is not already bound, initialize it to VALUE.
The remaining arguments should have the form
- [KEYWORD VALUE]... DOC
-
-where DOC is the variable documentation.
+ [KEYWORD VALUE]...
The following KEYWORD's are defined:
-:type VALUE should be a sexp widget.
-:group VALUE should be a customization group.
+:type VALUE should be a widget type.
+:options VALUE should be a list of valid members of the widget type.
+:group VALUE should be a customization group.
Add SYMBOL to that group.
Read the section about customization in the emacs lisp manual for more
information."
- `(custom-declare-variable (quote ,symbol) (quote ,value) ,@args))
+ `(eval-and-compile
+ (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)))
;;; The `defface' Macro.
-;;;###autoload
-(defun custom-declare-face (face spec &rest args)
- "Like `defface', but FACE is evaluated as a normal argument."
- (put face 'factory-face spec)
- (let ((value (or (get face 'saved-face) spec)))
- (custom-face-display-set face value))
- (while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (cond ((symbolp arg)
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" :type))
- (setq args (cdr args))
- (cond ((eq keyword :group)
- (custom-add-to-group value face 'custom-face))
- (t
- (error "Unknown keyword %s" face)))))
- ((stringp arg)
- (put face 'face-documentation arg)
- (when args
- (error "Junk at end of args %s" args)))
- (t
- (error "Junk in args %S"))))))
-
-;;;###autoload
-(defmacro defface (face spec &rest args)
+(defmacro defface (face spec doc &rest args)
"Declare FACE as a customizable face that defaults to SPEC.
FACE does not need to be quoted.
+Third argument DOC is the face documentation.
+
If FACE has been set with `custom-set-face', set the face attributes
as specified by that function, otherwise set the face attributes
according to SPEC.
The remaining arguments should have the form
- [KEYWORD VALUE]... DOC
-
-where DOC is the face documentation.
+ [KEYWORD VALUE]...
The following KEYWORD's are defined:
Read the section about customization in the emacs lisp manual for more
information."
- `(custom-declare-face (quote ,face) ,spec ,@args))
+ `(custom-declare-face (quote ,face) ,spec ,doc ,@args))
;;; The `defgroup' Macro.
-;;;###autoload
-(defun custom-declare-group (symbol members &rest args)
+(defun custom-declare-group (symbol members doc &rest args)
"Like `defgroup', but SYMBOL is evaluated as a normal argument."
(put symbol 'custom-group (nconc members (get symbol 'custom-group)))
- (while args
+ (when doc
+ (put symbol 'group-documentation doc))
+ (while args
(let ((arg (car args)))
(setq args (cdr args))
- (cond ((symbolp arg)
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" :type))
- (setq args (cdr args))
- (cond ((eq keyword :group)
- (custom-add-to-group value symbol 'custom-group))
- (t
- (error "Unknown keyword %s" symbol)))))
- ((stringp arg)
- (put symbol 'group-documentation arg)
- (when args
- (error "Junk at end of args %s" args)))
- (t
- (error "Junk in args %S"))))))
-
-;;;###autoload
-(defmacro defgroup (symbol members &rest args)
+ (unless (symbolp arg)
+ (error "Junk in args %S" args))
+ (let ((keyword arg)
+ (value (car args)))
+ (unless args
+ (error "Keyword %s is missing an argument" keyword))
+ (setq args (cdr args))
+ (cond ((eq keyword :prefix)
+ (put symbol 'custom-prefix value))
+ (t
+ (custom-handle-keyword symbol keyword value
+ 'custom-group))))))
+ (run-hooks 'custom-define-hook)
+ symbol)
+
+(defmacro defgroup (symbol members doc &rest args)
"Declare SYMBOL as a customization group containing MEMBERS.
SYMBOL does not need to be quoted.
+Third arg DOC is the group documentation.
+
MEMBERS should be an alist of the form ((NAME WIDGET)...) where
NAME is a symbol and WIDGET is a widget is a widget for editing that
symbol. Useful widgets are `custom-variable' for editing variables,
The remaining arguments should have the form
- [KEYWORD VALUE]... DOC
-
-where DOC is the group documentation.
+ [KEYWORD VALUE]...
The following KEYWORD's are defined:
Read the section about customization in the emacs lisp manual for more
information."
- `(custom-declare-group (quote ,symbol) ,members ,@args))
+ `(custom-declare-group (quote ,symbol) ,members ,doc ,@args))
-;;;###autoload
(defun custom-add-to-group (group option widget)
"To existing GROUP add a new OPTION of type WIDGET,
If there already is an entry for that option, overwrite it."
(setcar (cdr old) widget)
(put group 'custom-group (nconc members (list (list option widget)))))))
+;;; Properties.
+
+(defun custom-handle-all-keywords (symbol args type)
+ "For customization option SYMBOL, handle keyword arguments ARGS.
+Third argument TYPE is the custom option type."
+ (while args
+ (let ((arg (car args)))
+ (setq args (cdr args))
+ (unless (symbolp arg)
+ (error "Junk in args %S" args))
+ (let ((keyword arg)
+ (value (car args)))
+ (unless args
+ (error "Keyword %s is missing an argument" keyword))
+ (setq args (cdr args))
+ (custom-handle-keyword symbol keyword value type)))))
+
+(defun custom-handle-keyword (symbol keyword value type)
+ "For customization option SYMBOL, handle KEYWORD with VALUE.
+Fourth argument TYPE is the custom option type."
+ (cond ((eq keyword :group)
+ (custom-add-to-group value symbol type))
+ ((eq keyword :link)
+ (custom-add-link symbol value))
+ ((eq keyword :load)
+ (custom-add-load symbol value))
+ ((eq keyword :tag)
+ (put symbol 'custom-tag value))
+ (t
+ (error "Unknown keyword %s" symbol))))
+
+(defun custom-add-option (symbol option)
+ "To the variable SYMBOL add OPTION.
+
+If SYMBOL is a hook variable, OPTION should be a hook member.
+For other types variables, the effect is undefined."
+ (let ((options (get symbol 'custom-options)))
+ (unless (member option options)
+ (put symbol 'custom-options (cons option options)))))
+
+(defun custom-add-link (symbol widget)
+ "To the custom option SYMBOL add the link WIDGET."
+ (let ((links (get symbol 'custom-links)))
+ (unless (member widget links)
+ (put symbol 'custom-links (cons widget links)))))
+
+(defun custom-add-load (symbol load)
+ "To the custom option SYMBOL add the dependency LOAD.
+LOAD should be either a library file name, or a feature name."
+ (let ((loads (get symbol 'custom-loads)))
+ (unless (member load loads)
+ (put symbol 'custom-loads (cons load loads)))))
+
;;; Initializing.
-;;;###autoload
(defun custom-set-variables (&rest args)
- "Initialize variables according to user preferences.
-The arguments should have the form [SYMBOL VALUE]...
-For each symbol, VALUE is evaluated and bound as the default value for
-the symbol. The unevaluated VALUE is also stored as the saved value
-for that symbol."
- (while args
- (let ((symbol (nth 0 args))
- (value (nth 1 args)))
- (set-default symbol (eval value))
- (put symbol 'saved-value (list value)))
- (setq args (cdr (cdr args)))))
-
-;;;###autoload
-(defun custom-set-faces (&rest args)
- "Initialize faces according to user preferences.
-The arguments should have the form [SYMBOL SPEC]...
-For each symbol, a face with that name is created according to SPEC.
-See `defface' for the format of SPEC."
+ "Initialize variables according to user preferences.
+
+The arguments should be a list where each entry has the form:
+
+ (SYMBOL VALUE [NOW])
+
+The unevaluated VALUE is stored as the saved value for SYMBOL.
+If NOW is present and non-nil, VALUE is also evaluated and bound as
+the default value for the SYMBOL."
(while args
- (let ((face (nth 0 args))
- (spec (nth 1 args)))
- (put face 'saved-face spec)
- (custom-face-display-set face spec))
- (setq args (cdr (cdr args)))))
+ (let ((entry (car args)))
+ (if (listp entry)
+ (let ((symbol (nth 0 entry))
+ (value (nth 1 entry))
+ (now (nth 2 entry)))
+ (put symbol 'saved-value (list value))
+ (when now
+ (put symbol 'force-value t)
+ (set-default symbol (eval value)))
+ (setq args (cdr args)))
+ ;; Old format, a plist of SYMBOL VALUE pairs.
+ (let ((symbol (nth 0 args))
+ (value (nth 1 args)))
+ (put symbol 'saved-value (list value)))
+ (setq args (cdr (cdr args)))))))
;;; Meta Customization
-(defgroup emacs nil
- "Customization of the One True Editor.")
-
-(defgroup customize nil
- :group 'emacs
- "Customization of the Customization support.")
+(defcustom custom-define-hook nil
+ "Hook called after defining each customize option."
+ :group 'customize
+ :type 'hook)
+
+;;; Menu support
+
+(defconst custom-help-menu '("Customize"
+ ["Update menu..." custom-menu-update t]
+ ["Group..." customize t]
+ ["Variable..." customize-variable t]
+ ["Face..." customize-face t]
+ ["Saved..." customize-customized t]
+ ["Apropos..." customize-apropos t])
+ "Customize menu")
+
+(defun custom-menu-reset ()
+ "Reset customize menu."
+ (remove-hook 'custom-define-hook 'custom-menu-reset)
+ (if (string-match "XEmacs" emacs-version)
+ (when (fboundp 'add-submenu)
+ (add-submenu '("Help") custom-help-menu))
+ (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))))))
;;; The End.
projects / gnus / blobdiff