lisp/cus-face.el

   1 ;;; cus-face.el -- customization support for faces.
   2 ;;
   3 ;; Copyright (C) 1996, 1997, 1999 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: help, faces
   7 ;; Version: Emacs
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; See `custom.el'.
  29
  30 ;;; Code:
  31
  32 (defalias 'custom-facep 'facep)
  33
  34 ;;; Declaring a face.
  35
  36 ;;;###autoload
  37 (defun custom-declare-face (face spec doc &rest args)
  38   "Like `defface', but FACE is evaluated as a normal argument."
  39   (unless (get face 'face-defface-spec)
  40     (put face 'face-defface-spec spec)
  41     (when (fboundp 'facep)
  42       (unless (facep face)
  43         ;; If the user has already created the face, respect that.
  44         (let ((value (or (get face 'saved-face) spec))
  45               (frames (frame-list))
  46               frame)
  47           ;; Create global face.
  48           (make-empty-face face)
  49           ;; Create frame local faces
  50           (while frames
  51             (setq frame (car frames)
  52                   frames (cdr frames))
  53             (face-spec-set face value frame)))
  54         ;; When making a face after frames already exist
  55         (if (memq window-system '(x w32))
  56             (make-face-x-resource-internal face))))
  57     (when (and doc (null (face-documentation face)))
  58       (set-face-documentation face (purecopy doc)))
  59     (custom-handle-all-keywords face args 'custom-face)
  60     (run-hooks 'custom-define-hook))
  61   face)
  62
  63 ;;; Face attributes.
  64
  65 ;; Below, nil is used in widget specifications for `unspecified' face
  66 ;; attributes and `off' is used instead of nil attribute values.  The
  67 ;; reason for this is that nil corresponds to the result you get when
  68 ;; looking up an attribute in a defface spec that isn't contained in
  69 ;; the spec.
  70
  71 (defconst custom-face-attributes
  72   '((:family
  73      (choice :tag "Font family"
  74              :help-echo "Font family or fontset alias name."
  75              (const :tag "*" nil)
  76              (string :tag "Family"))
  77      (lambda (face value &optional frame)
  78        (set-face-attribute face frame :family (or value 'unspecified)))
  79      (lambda (face &optional frame)
  80        (let ((family (face-attribute face :family frame)))
  81          (if (eq family 'unspecified) nil family))))
  82
  83     (:width
  84      (choice :tag "Width"
  85              :help-echo "Font width."
  86              (const :tag "*" nil)
  87              (const :tag "compressed" condensed)
  88              (const :tag "condensed" condensed)
  89              (const :tag "demiexpanded" semi-expanded)
  90              (const :tag "expanded" expanded)
  91              (const :tag "extracondensed" extra-condensed)
  92              (const :tag "extraexpanded" extra-expanded)
  93              (const :tag "medium" normal)
  94              (const :tag "narrow" condensed)
  95              (const :tag "normal" normal)
  96              (const :tag "regular" normal)
  97              (const :tag "semicondensed" semi-condensed)
  98              (const :tag "semiexpanded" semi-expanded)
  99              (const :tag "ultracondensed" ultra-condensed)
 100              (const :tag "ultraexpanded" ultra-expanded)
 101              (const :tag "wide" extra-expanded))
 102      (lambda (face value &optional frame)
 103        (set-face-attribute face frame :width (or value 'unspecified)))
 104      (lambda (face &optional frame)
 105        (let ((width (face-attribute face :width frame)))
 106          (if (eq width 'unspecified) nil width))))
 107
 108     (:height
 109      (choice :tag "Height"
 110              :help-echo "Face's font height."
 111              (const :tag "*" nil)
 112              (integer :tag "Height in 1/10 pt")
 113              (number :tag "Scale" 1.0))
 114      (lambda (face value &optional frame)
 115        (set-face-attribute face frame :height (or value 'unspecified)))
 116      (lambda (face &optional frame)
 117        (let ((height (face-attribute face :height frame)))
 118          (if (eq height 'unspecified) nil height))))
 119
 120     (:weight
 121      (choice :tag "Weight"
 122              :help-echo "Font weight."
 123              (const :tag "*" nil)
 124              (const :tag "black" ultra_bold)
 125              (const :tag "bold" bold)
 126              (const :tag "book" semi-light)
 127              (const :tag "demibold" semi-bold)
 128              (const :tag "extralight" extra-light)
 129              (const :tag "extrabold" extra-bold)
 130              (const :tag "heavy" extra-bold)
 131              (const :tag "light" light)
 132              (const :tag "medium" normal)
 133              (const :tag "normal" normal)
 134              (const :tag "regular" normal)
 135              (const :tag "semibold" semi-bold)
 136              (const :tag "semilight" semi-light)
 137              (const :tag "ultralight" ultra-light)
 138              (const :tag "ultrabold" ultra-bold))
 139      (lambda (face value &optional frame)
 140        (set-face-attribute face frame :weight (or value 'unspecified)))
 141      (lambda (face &optional frame)
 142        (let ((weight (face-attribute face :weight frame)))
 143          (if (eq weight 'unspecified) nil weight))))
 144
 145     (:slant
 146      (choice :tag "Slant"
 147              :help-echo "Font slant."
 148              (const :tag "*" nil)
 149              (const :tag "italic" italic)
 150              (const :tag "oblique" oblique)
 151              (const :tag "normal" normal))
 152      (lambda (face value &optional frame)
 153        (set-face-attribute face frame :slant (or value 'unspecified)))
 154      (lambda (face &optional frame)
 155        (let ((slant (face-attribute face :slant frame)))
 156          (if (eq slant 'unspecified) nil slant))))
 157
 158     (:underline
 159      (choice :tag "Underline"
 160              :help-echo "Control text underlining."
 161              (const :tag "*" nil)
 162              (const :tag "On" t)
 163              (const :tag "Off" off)
 164              (color :tag "Colored"))
 165      (lambda (face value &optional frame)
 166        (cond ((eq value 'off) (setq value nil))
 167              ((null value) (setq value 'unspecified)))
 168        (set-face-attribute face frame :underline value))
 169      (lambda (face &optional frame)
 170        (let ((underline (face-attribute face :underline frame)))
 171          (cond ((eq underline 'unspecified) nil)
 172                ((null underline) 'off)))))
 173
 174     (:overline
 175      (choice :tag "Overline"
 176              :help-echo "Control text overlining."
 177              (const :tag "*" nil)
 178              (const :tag "On" t)
 179              (const :tag "Off" off)
 180              (color :tag "Colored"))
 181      (lambda (face value &optional frame)
 182        (cond ((eq value 'off) (setq value nil))
 183              ((null value) (setq value 'unspecified)))
 184        (set-face-attribute face frame :overline value))
 185      (lambda (face &optional frame)
 186        (let ((overline (face-attribute face :overline frame)))
 187          (cond ((eq overline 'unspecified) nil)
 188                ((null overline) 'off)))))
 189
 190     (:strike-through
 191      (choice :tag "Strike-through"
 192              :help-echo "Control text strike-through."
 193              (const :tag "*" nil)
 194              (const :tag "On" t)
 195              (const :tag "Off" off)
 196              (color :tag "Colored"))
 197      (lambda (face value &optional frame)
 198        (cond ((eq value 'off) (setq value nil))
 199              ((null value) (setq value 'unspecified)))
 200        (set-face-attribute face frame :strike-through value))
 201      (lambda (face &optional frame)
 202        (let ((value (face-attribute face :strike-through frame)))
 203          (cond ((eq value 'unspecified) (setq value nil))
 204                ((null value) (setq value 'off)))
 205          value)))
 206
 207     (:box
 208      ;; Fixme: this can probably be done better.
 209      (choice :tag "Box around text"
 210              :help-echo "Control box around text."
 211              (const :tag "*" t)
 212              (const :tag "Off" nil)
 213              (list :tag "Box"
 214                    :value (:line-width 2 :color "grey75"
 215                                        :style released-button)
 216                    (const :format "" :value :line-width)
 217                    (integer :tag "Width")
 218                    (const :format "" :value :color)
 219                    (choice :tag "Color" (const :tag "*" nil) color)
 220                    (const :format "" :value :style)
 221                    (choice :tag "Style"
 222                            (const :tag "Raised" released-button)
 223                            (const :tag "Sunken" pressed-button)
 224                            (const :tag "None" nil))))
 225      (lambda (face value &optional frame)
 226        (set-face-attribute face frame :box value))
 227      (lambda (face &optional frame)
 228        (let ((value (face-attribute face :box frame)))
 229          (if (consp value)
 230              (list :line-width (or (plist-get value :line-width) 1)
 231                    :color (plist-get value :color)
 232                    :style (plist-get value :style))
 233            value))))
 234
 235     (:inverse-video
 236      (choice :tag "Inverse-video"
 237              :help-echo "Control whether text should be in inverse-video."
 238              (const :tag "*" nil)
 239              (const :tag "On" t)
 240              (const :tag "Off" off))
 241      (lambda (face value &optional frame)
 242        (cond ((eq value 'off) (setq value nil))
 243              ((null value) (setq value 'unspecified)))
 244        (set-face-attribute face frame :inverse-video value))
 245      (lambda (face &optional frame)
 246        (let ((value (face-attribute face :inverse-video frame)))
 247          (cond ((eq value 'unspecified)
 248                 nil)
 249                ((null value)'off)))))
 250
 251     (:foreground
 252      (choice :tag "Foreground"
 253              :help-echo "Set foreground color."
 254              (const :tag "*" nil)
 255              (color :tag "Color"))
 256      (lambda (face value &optional frame)
 257        (set-face-attribute face frame :foreground (or value 'unspecified)))
 258      (lambda (face &optional frame)
 259        (let ((value (face-attribute face :foreground frame)))
 260          (if (eq value 'unspecified) nil value))))
 261
 262     (:background
 263      (choice :tag "Background"
 264              :help-echo "Set background color."
 265              (const :tag "*" nil)
 266              (color :tag "Color"))
 267      (lambda (face value &optional frame)
 268        (set-face-attribute face frame :background (or value 'unspecified)))
 269      (lambda (face &optional frame)
 270        (let ((value (face-attribute face :background frame)))
 271          (if (eq value 'unspecified) nil value))))
 272
 273     (:stipple
 274      (choice :tag "Stipple"
 275              :help-echo "Name of background bitmap file."
 276              (const :tag "*" nil)
 277              (file :tag "File" :must-match t))
 278      (lambda (face value &optional frame)
 279        (set-face-attribute face frame :stipple (or value 'unspecified)))
 280      (lambda (face &optional frame)
 281        (let ((value (face-attribute face :stipple frame)))
 282          (if (eq value 'unspecified) nil value))))
 283
 284     (:inherit
 285      (repeat :tag "Inherit"
 286              :help-echo "List of faces to inherit attributes from."
 287              (face :Tag "Face" default))
 288      (lambda (face value &optional frame)
 289        (message "Setting to: <%s>" value)
 290        (set-face-attribute face frame :inherit
 291                            (if (and (consp value) (null (cdr value)))
 292                                (car value)
 293                              value)))
 294      (lambda (face &optional frame)
 295        (let ((value (face-attribute face :inherit frame)))
 296          (cond ((or (null value) (eq value 'unspecified))
 297                 nil)
 298                ((symbolp value)
 299                 (list value))
 300                (t
 301                 value))))))
 302
 303   "Alist of face attributes.
 304
 305 The elements are of the form (KEY TYPE SET GET), where KEY is the name
 306 of the attribute, TYPE is a widget type for editing the attibute, SET
 307 is a function for setting the attribute value, and GET is a function
 308 for getiing the attribute value.
 309
 310 The SET function should take three arguments, the face to modify, the
 311 value of the attribute, and optionally the frame where the face should
 312 be changed.
 313
 314 The GET function should take two arguments, the face to examine, and
 315 optionally the frame where the face should be examined.")
 316
 317
 318 (defun custom-face-attributes-get (face frame)
 319   "For FACE on FRAME, return an alternating list describing its attributes.
 320 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
 321 Each keyword should be listed in `custom-face-attributes'.
 322
 323 If FRAME is nil, use the global defaults for FACE."
 324   (let ((attrs custom-face-attributes)
 325         plist)
 326     (while attrs
 327       (let* ((attribute (car (car attrs)))
 328              (value (face-attribute face attribute frame)))
 329         (setq attrs (cdr attrs))
 330         (unless (or (eq value 'unspecified)
 331                     (and (null value) (memq attribute '(:inherit))))
 332           (setq plist (cons attribute (cons value plist))))))
 333     plist))
 334
 335 ;;; Initializing.
 336
 337 ;;;###autoload
 338 (defun custom-set-faces (&rest args)
 339   "Initialize faces according to user preferences.
 340 The arguments should be a list where each entry has the form:
 341
 342   (FACE SPEC [NOW [COMMENT]])
 343
 344 SPEC is stored as the saved value for FACE.
 345 If NOW is present and non-nil, FACE is created now, according to SPEC.
 346 COMMENT is a string comment about FACE.
 347
 348 See `defface' for the format of SPEC."
 349   (while args
 350     (let ((entry (car args)))
 351       (if (listp entry)
 352           (let ((face (nth 0 entry))
 353                 (spec (nth 1 entry))
 354                 (now (nth 2 entry))
 355                 (comment (nth 3 entry)))
 356             (put face 'saved-face spec)
 357             (put face 'saved-face-comment comment)
 358             (when now
 359               (put face 'force-face t))
 360             (when (or now (facep face))
 361               (put face 'face-comment comment)
 362               (make-empty-face face)
 363               (face-spec-set face spec))
 364             (setq args (cdr args)))
 365         ;; Old format, a plist of FACE SPEC pairs.
 366         (let ((face (nth 0 args))
 367               (spec (nth 1 args)))
 368           (put face 'saved-face spec))
 369         (setq args (cdr (cdr args)))))))
 370
 371 ;;; The End.
 372
 373 (provide 'cus-face)
 374
 375 ;;; cus-face.el ends here