cgit.sxemacs.org Git - gnus/blob - lisp/custom.el

   1 ;;; custom.el -- Tools for declaring and initializing options.
   2 ;;
   3 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: help, faces
   7 ;; Version: 0.995
   8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
   9
  10 ;;; Commentary:
  11 ;;
  12 ;; If you want to use this code, please visit the URL above.
  13 ;;
  14 ;; This file only contain the code needed to declare and initialize
  15 ;; user options.  The code to customize options is autoloaded from
  16 ;; `custom-edit.el'.
  17
  18 ;;; Code:
  19
  20 (require 'widget)
  21
  22 (define-widget-keywords :options :type :group)
  23
  24 ;; These autoloads should be deleted when the file is added to Emacs
  25 (autoload 'customize "custom-edit" nil t)
  26 (autoload 'customize-variable "custom-edit" nil t)
  27 (autoload 'customize-face "custom-edit" nil t)
  28 (autoload 'customize-apropos "custom-edit" nil t)
  29
  30 ;;; Compatibility.
  31
  32 (fset 'custom-x-color-values
  33       (if (fboundp 'x-color-values)
  34           'x-color-values
  35         (lambda (color)
  36           (color-instance-rgb-components
  37            (make-color-instance color)))))
  38
  39 (defun custom-background-mode ()
  40   "Kludge to detext background mode."
  41   (let* ((bg-resource
  42           (condition-case ()
  43               (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
  44             (error nil)))
  45          (params (frame-parameters))
  46          (color (condition-case ()
  47                     (or (assq 'background-color params)
  48                         (color-instance-name
  49                          (specifier-instance
  50                           (face-background 'default))))
  51                   (error nil)))
  52          (mode (cond (bg-resource (intern (downcase bg-resource)))
  53                      ((and color
  54                            (< (apply '+ (custom-x-color-values color))
  55                               (/ (apply '+ (custom-x-color-values "white"))
  56                                  3)))
  57                       'dark)
  58                      (t 'light))))
  59     (if (fboundp 'set-frame-property)
  60         ;; `modify-frame-properties' is borken on XEmacs 19.14.
  61         (set-frame-property (selected-frame) 'background-mode mode)
  62       ;; `set-frame-property' is unimplemented in Emacs 19.34.
  63       (modify-frame-parameters (selected-frame)
  64                                (cons (cons 'background-mode mode) params)))
  65     mode))
  66
  67 ;;; The `defcustom' Macro.
  68
  69 ;;;###autoload
  70 (defun custom-declare-variable (symbol value doc &rest args)
  71   "Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments."
  72   (unless (default-boundp symbol)
  73     (set-default symbol (if (get symbol 'saved-value)
  74                             (eval (car (get symbol 'saved-value)))
  75                           (eval value))))
  76   (put symbol 'factory-value (list value))
  77   (when doc
  78     (put symbol 'variable-documentation doc))
  79   (while args
  80     (let ((arg (car args)))
  81       (setq args (cdr args))
  82       (unless (symbolp arg)
  83         (error "Junk in args %S" args))
  84       (let ((keyword arg)
  85             (value (car args)))
  86         (unless args
  87           (error "Keyword %s is missing an argument" keyword))
  88         (setq args (cdr args))
  89         (cond ((eq keyword :type)
  90                (put symbol 'custom-type value))
  91               ((eq keyword :options)
  92                (put symbol 'custom-options
  93                     (append value (get symbol 'custom-options))))
  94               ((eq keyword :group)
  95                (custom-add-to-group value symbol 'custom-variable))
  96               (t
  97                (error "Unknown keyword %s" symbol)))))))
  98
  99 ;;;###autoload
 100 (defmacro defcustom (symbol value doc &rest args)
 101   "Declare SYMBOL as a customizable variable that defaults to VALUE.
 102 DOC is the variable documentation.
 103
 104 Neither SYMBOL nor VALUE needs to be quoted.
 105 If SYMBOL is not already bound, initialize it to VALUE.
 106 The remaining arguments should have the form
 107
 108    [KEYWORD VALUE]...
 109
 110 The following KEYWORD's are defined:
 111
 112 :type   VALUE should be a widget type.
 113 :options VALUE should be a list of valid members of the widget type.
 114 :group  VALUE should be a customization group.
 115         Add SYMBOL to that group.
 116
 117 Read the section about customization in the emacs lisp manual for more
 118 information."
 119   `(eval-and-compile
 120      (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)))
 121
 122 ;;; The `defface' Macro.
 123
 124 ;;;###autoload
 125 (defun custom-declare-face (face spec doc &rest args)
 126   "Like `defface', but FACE is evaluated as a normal argument."
 127   (put face 'factory-face spec)
 128   (when (fboundp 'facep)
 129     (unless (facep face)
 130       ;; If the user has already created the face, respect that.
 131       (let ((value (or (get face 'saved-face) spec)))
 132         (custom-face-display-set face value))))
 133   (when doc
 134     (put face 'face-documentation doc))
 135   (while args
 136     (let ((arg (car args)))
 137       (setq args (cdr args))
 138       (unless (symbolp arg)
 139         (error "Junk in args %S" args))
 140       (let ((keyword arg)
 141             (value (car args)))
 142         (unless args
 143           (error "Keyword %s is missing an argument" :type))
 144         (setq args (cdr args))
 145         (cond ((eq keyword :group)
 146                (custom-add-to-group value face 'custom-face))
 147               (t
 148                (error "Unknown keyword %s" face)))))))
 149
 150 ;;;###autoload
 151 (defmacro defface (face spec doc &rest args)
 152   "Declare FACE as a customizable face that defaults to SPEC.
 153 FACE does not need to be quoted.
 154
 155 Third argument DOC is the face documentation.
 156
 157 If FACE has been set with `custom-set-face', set the face attributes
 158 as specified by that function, otherwise set the face attributes
 159 according to SPEC.
 160
 161 The remaining arguments should have the form
 162
 163    [KEYWORD VALUE]...
 164
 165 The following KEYWORD's are defined:
 166
 167 :group  VALUE should be a customization group.
 168         Add FACE to that group.
 169
 170 SPEC should be an alist of the form ((DISPLAY ATTS)...).
 171
 172 ATTS is a list of face attributes and their values.  The possible
 173 attributes are defined in the variable `custom-face-attributes'.
 174 Alternatively, ATTS can be a face in which case the attributes of that
 175 face is used.
 176
 177 The ATTS of the first entry in SPEC where the DISPLAY matches the
 178 frame should take effect in that frame.  DISPLAY can either be the
 179 symbol `t', which will match all frames, or an alist of the form
 180 \((REQ ITEM...)...)
 181
 182 For the DISPLAY to match a FRAME, the REQ property of the frame must
 183 match one of the ITEM.  The following REQ are defined:
 184
 185 `type' (the value of (window-system))
 186   Should be one of `x' or `tty'.
 187
 188 `class' (the frame's color support)
 189   Should be one of `color', `grayscale', or `mono'.
 190
 191 `background' (what color is used for the background text)
 192   Should be one of `light' or `dark'.
 193
 194 Read the section about customization in the emacs lisp manual for more
 195 information."
 196   `(custom-declare-face (quote ,face) ,spec ,doc ,@args))
 197
 198 ;;; The `defgroup' Macro.
 199
 200 ;;;###autoload
 201 (defun custom-declare-group (symbol members doc &rest args)
 202   "Like `defgroup', but SYMBOL is evaluated as a normal argument."
 203   (put symbol 'custom-group (nconc members (get symbol 'custom-group)))
 204   (when doc
 205     (put symbol 'group-documentation doc))
 206   (while args
 207     (let ((arg (car args)))
 208       (setq args (cdr args))
 209       (unless (symbolp arg)
 210         (error "Junk in args %S" args))
 211       (let ((keyword arg)
 212             (value (car args)))
 213         (unless args
 214           (error "Keyword %s is missing an argument" :type))
 215         (setq args (cdr args))
 216         (cond ((eq keyword :group)
 217                (custom-add-to-group value symbol 'custom-group))
 218               (t
 219                (error "Unknown keyword %s" symbol)))))))
 220
 221 ;;;###autoload
 222 (defmacro defgroup (symbol members doc &rest args)
 223   "Declare SYMBOL as a customization group containing MEMBERS.
 224 SYMBOL does not need to be quoted.
 225
 226 Third arg DOC is the group documentation.
 227
 228 MEMBERS should be an alist of the form ((NAME WIDGET)...) where
 229 NAME is a symbol and WIDGET is a widget is a widget for editing that
 230 symbol.  Useful widgets are `custom-variable' for editing variables,
 231 `custom-face' for edit faces, and `custom-group' for editing groups.
 232
 233 The remaining arguments should have the form
 234
 235    [KEYWORD VALUE]...
 236
 237 The following KEYWORD's are defined:
 238
 239 :group  VALUE should be a customization group.
 240         Add SYMBOL to that group.
 241
 242 Read the section about customization in the emacs lisp manual for more
 243 information."
 244   `(custom-declare-group (quote ,symbol) ,members ,doc ,@args))
 245
 246 ;;;###autoload
 247 (defun custom-add-to-group (group option widget)
 248   "To existing GROUP add a new OPTION of type WIDGET,
 249 If there already is an entry for that option, overwrite it."
 250   (let* ((members (get group 'custom-group))
 251          (old (assq option members)))
 252     (if old
 253         (setcar (cdr old) widget)
 254       (put group 'custom-group (nconc members (list (list option widget)))))))
 255
 256 ;;; Face Utilities.
 257
 258 (and (fboundp 'make-face)
 259      (make-face 'custom-face-empty))
 260
 261 (defun custom-face-display-set (face spec &optional frame)
 262   "Set FACE to the attributes to the first matching entry in SPEC.
 263 Iff optional FRAME is non-nil, set it for that frame only.
 264 See `defface' for information about SPEC."
 265   (when (fboundp 'make-face)
 266     (make-face face)
 267     (copy-face 'custom-face-empty face)
 268     (while spec
 269       (let* ((entry (car spec))
 270              (display (nth 0 entry))
 271              (atts (nth 1 entry)))
 272         (setq spec (cdr spec))
 273         (when (custom-display-match-frame display frame)
 274           (apply 'custom-face-attribites-set face frame atts)
 275           (setq spec nil))))))
 276
 277 (defcustom custom-background-mode nil
 278   "The brightness of the background.
 279 Set this to the symbol dark if your background color is dark, light if
 280 your background is light, or nil (default) if you want Emacs to
 281 examine the brightness for you."
 282   :group 'customize
 283   :type '(choice (choice-item dark)
 284                  (choice-item light)
 285                  (choice-item :tag "default" nil)))
 286
 287 (defun custom-display-match-frame (display frame)
 288   "Non-nil iff DISPLAY matches FRAME.
 289 If FRAME is nil, the current FRAME is used."
 290   ;; This is a kludge to get started, we really should use specifiers!
 291   (unless frame
 292     (setq frame (selected-frame)))
 293   (if (eq display t)
 294       t
 295     (let ((match t)
 296           (pars (frame-parameters frame)))
 297       (while (and display match)
 298         (let* ((entry (car display))
 299                (req (car entry))
 300                (options (cdr entry)))
 301           (setq display (cdr display))
 302           (cond ((eq req 'type)
 303                  (let ((type (if (fboundp 'device-type)
 304                                  (device-type frame)
 305                                window-system)))
 306                    (setq match (memq type options))))
 307                 ((eq req 'class)
 308                  (let ((class (if (fboundp 'device-class)
 309                                   (device-class frame)
 310                                 (cdr (assq 'display-type pars)))))
 311                    (setq match (memq class options))))
 312                 ((eq req 'background)
 313                  (let ((background (or custom-background-mode
 314                                        (cdr (assq 'background-mode pars))
 315                                        (custom-background-mode))))
 316                    (setq match (memq background options))))
 317                 (t
 318                  (error "Unknown req `%S' with options `%S'" req options)))))
 319       match)))
 320
 321 (defvar custom-face-attributes
 322   '((:bold (toggle :format "Bold: %v") custom-set-face-bold)
 323     (:italic (toggle :format "Italic: %v") custom-set-face-italic)
 324     (:underline
 325      (toggle :format "Underline: %v") set-face-underline-p)
 326     (:foreground (color :tag "Foreground") set-face-foreground)
 327     (:background (color :tag "Background") set-face-background)
 328     (:stipple (editable-field :format "Stipple: %v") set-face-stipple))
 329   "Alist of face attributes.
 330
 331 The elements are of the form (KEY TYPE SET) where KEY is a symbol
 332 identifying the attribute, TYPE is a widget type for editing the
 333 attibute, SET is a function for setting the attribute value.
 334
 335 The SET function should take three arguments, the face to modify, the
 336 value of the attribute, and optionally the frame where the face should
 337 be changed.")
 338
 339 (defun custom-face-attribites-set (face frame &rest atts)
 340   "For FACE on FRAME set the attributes [KEYWORD VALUE]....
 341 Each keyword should be listed in `custom-face-attributes'.
 342
 343 If FRAME is nil, set the default face."
 344   (while atts
 345     (let* ((name (nth 0 atts))
 346            (value (nth 1 atts))
 347            (fun (nth 2 (assq name custom-face-attributes))))
 348       (setq atts (cdr (cdr atts)))
 349       (condition-case nil
 350           (funcall fun face value)
 351         (error nil)))))
 352
 353 (defun custom-set-face-bold (face value &optional frame)
 354   "Set the bold property of FACE to VALUE."
 355   (if value
 356       (make-face-bold face frame)
 357     (make-face-unbold face frame)))
 358
 359 (defun custom-set-face-italic (face value &optional frame)
 360   "Set the italic property of FACE to VALUE."
 361   (if value
 362       (make-face-italic face frame)
 363     (make-face-unitalic face frame)))
 364
 365 ;;;###autoload
 366 (defun custom-initialize-faces (&optional frame)
 367   "Initialize all custom faces for FRAME.
 368 If FRAME is nil or omitted, initialize them for all frames."
 369   (mapatoms (lambda (symbol)
 370               (let ((spec (or (get symbol 'saved-face)
 371                               (get symbol 'factory-face))))
 372                 (when spec
 373                   (custom-face-display-set symbol spec frame))))))
 374
 375 ;;; Initializing.
 376
 377 ;;;###autoload
 378 (defun custom-set-variables (&rest args)
 379   "Initialize variables according to user preferences.
 380 The arguments should have the form [SYMBOL VALUE]...
 381 For each symbol, VALUE is evaluated and bound as the default value for
 382 the symbol.  The unevaluated VALUE is also stored as the saved value
 383 for that symbol."
 384   (while args
 385     (let ((symbol (nth 0 args))
 386           (value (nth 1 args)))
 387       (put symbol 'saved-value (list value)))
 388     (setq args (cdr (cdr args)))))
 389
 390 ;;;###autoload
 391 (defun custom-set-faces (&rest args)
 392   "Initialize faces according to user preferences.
 393 The arguments should have the form [SYMBOL SPEC]...
 394 For each symbol, a face with that name is created according to SPEC.
 395 See `defface' for the format of SPEC."
 396   (while args
 397     (let ((face (nth 0 args))
 398           (spec (nth 1 args)))
 399       (put face 'saved-face spec))
 400     (setq args (cdr (cdr args)))))
 401
 402 ;;; Meta Customization
 403
 404 (defgroup emacs nil
 405   "Customization of the One True Editor.")
 406
 407 (defgroup customize nil
 408   "Customization of the Customization support."
 409   :group 'emacs)
 410
 411 ;;; The End.
 412
 413 (provide 'custom)
 414
 415 ;; custom.el ends here