lisp/cus-face.el

   1 ;;; cus-face.el --- customization support for faces
   2 ;;
   3 ;; Copyright (C) 1996, 1997, 1999, 2000 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
  78     (:width
  79      (choice :tag "Width"
  80              :help-echo "Font width."
  81              (const :tag "*" nil)
  82              (const :tag "compressed" condensed)
  83              (const :tag "condensed" condensed)
  84              (const :tag "demiexpanded" semi-expanded)
  85              (const :tag "expanded" expanded)
  86              (const :tag "extracondensed" extra-condensed)
  87              (const :tag "extraexpanded" extra-expanded)
  88              (const :tag "medium" normal)
  89              (const :tag "narrow" condensed)
  90              (const :tag "normal" normal)
  91              (const :tag "regular" normal)
  92              (const :tag "semicondensed" semi-condensed)
  93              (const :tag "semiexpanded" semi-expanded)
  94              (const :tag "ultracondensed" ultra-condensed)
  95              (const :tag "ultraexpanded" ultra-expanded)
  96              (const :tag "wide" extra-expanded)))
  97
  98     (:height
  99      (choice :tag "Height"
 100              :help-echo "Face's font height."
 101              (const :tag "*" nil)
 102              (integer :tag "Height in 1/10 pt")
 103              (number :tag "Scale" 1.0)))
 104
 105     (:weight
 106      (choice :tag "Weight"
 107              :help-echo "Font weight."
 108              (const :tag "*" nil)
 109              (const :tag "black" ultra_bold)
 110              (const :tag "bold" bold)
 111              (const :tag "book" semi-light)
 112              (const :tag "demibold" semi-bold)
 113              (const :tag "extralight" extra-light)
 114              (const :tag "extrabold" extra-bold)
 115              (const :tag "heavy" extra-bold)
 116              (const :tag "light" light)
 117              (const :tag "medium" normal)
 118              (const :tag "normal" normal)
 119              (const :tag "regular" normal)
 120              (const :tag "semibold" semi-bold)
 121              (const :tag "semilight" semi-light)
 122              (const :tag "ultralight" ultra-light)
 123              (const :tag "ultrabold" ultra-bold)))
 124
 125     (:slant
 126      (choice :tag "Slant"
 127              :help-echo "Font slant."
 128              (const :tag "*" nil)
 129              (const :tag "italic" italic)
 130              (const :tag "oblique" oblique)
 131              (const :tag "normal" normal)))
 132
 133     (:underline
 134      (choice :tag "Underline"
 135              :help-echo "Control text underlining."
 136              (const :tag "*" nil)
 137              (const :tag "On" t)
 138              (const :tag "Off" off)
 139              (color :tag "Colored")))
 140
 141     (:overline
 142      (choice :tag "Overline"
 143              :help-echo "Control text overlining."
 144              (const :tag "*" nil)
 145              (const :tag "On" t)
 146              (const :tag "Off" off)
 147              (color :tag "Colored")))
 148
 149     (:strike-through
 150      (choice :tag "Strike-through"
 151              :help-echo "Control text strike-through."
 152              (const :tag "*" nil)
 153              (const :tag "On" t)
 154              (const :tag "Off" off)
 155              (color :tag "Colored")))
 156
 157     (:box
 158      ;; Fixme: this can probably be done better.
 159      (choice :tag "Box around text"
 160              :help-echo "Control box around text."
 161              (const :tag "*" nil)
 162              (const :tag "Off" off)
 163              (list :tag "Box"
 164                    :value (:line-width 2 :color "grey75" :style released-button)
 165                    (const :format "" :value :line-width)
 166                    (integer :tag "Width")
 167                    (const :format "" :value :color)
 168                    (choice :tag "Color" (const :tag "*" nil) color)
 169                    (const :format "" :value :style)
 170                    (choice :tag "Style"
 171                            (const :tag "Raised" released-button)
 172                            (const :tag "Sunken" pressed-button)
 173                            (const :tag "None" nil))))
 174      ;; filter to make value suitable for customize
 175      (lambda (real-value)
 176        (if (null real-value)
 177            'off
 178          (let ((lwidth
 179                 (or (and (consp real-value) (plist-get real-value :line-width))
 180                     (and (integerp real-value) real-value)
 181                     1))
 182                (color
 183                 (or (and (consp real-value) (plist-get real-value :color))
 184                     (and (stringp real-value) real-value)
 185                     nil))
 186                (style
 187                 (and (consp real-value) (plist-get real-value :style))))
 188            (list :line-width lwidth :color color :style style))))
 189      ;; filter to make customized-value suitable for storing
 190      (lambda (cus-value)
 191        (cond ((null cus-value)
 192               'unspecified)
 193              ((eq cus-value 'off)
 194               nil)
 195              (t
 196               (let ((lwidth (plist-get cus-value :line-width))
 197                     (color (plist-get cus-value :color))
 198                     (style (plist-get cus-value :style)))
 199                 (cond ((and (null color) (null style))
 200                        lwidth)
 201                       ((and (null lwidth) (null style))
 202                        ;; actually can't happen, because LWIDTH is always an int
 203                        color)
 204                       (t
 205                        ;; Keep as a plist, but remove null entries
 206                        (nconc (and lwidth `(:line-width ,lwidth))
 207                               (and color  `(:color ,color))
 208                               (and style  `(:style ,style))))))))))
 209
 210     (:inverse-video
 211      (choice :tag "Inverse-video"
 212              :help-echo "Control whether text should be in inverse-video."
 213              (const :tag "*" nil)
 214              (const :tag "On" t)
 215              (const :tag "Off" off)))
 216
 217     (:foreground
 218      (choice :tag "Foreground"
 219              :help-echo "Set foreground color."
 220              (const :tag "*" nil)
 221              (color :tag "Color")))
 222
 223     (:background
 224      (choice :tag "Background"
 225              :help-echo "Set background color."
 226              (const :tag "*" nil)
 227              (color :tag "Color")))
 228
 229     (:stipple
 230      (choice :tag "Stipple"
 231              :help-echo "Background bit-mask"
 232              (const :tag "*" nil)
 233              (const :tag "None" off)
 234              (file :tag "File"
 235                    :help-echo "Name of bitmap file."
 236                    :must-match t)))
 237
 238     (:inherit
 239      (repeat :tag "Inherit"
 240              :help-echo "List of faces to inherit attributes from."
 241              (face :Tag "Face" default))
 242      ;; filter to make value suitable for customize
 243      (lambda (real-value)
 244        (cond ((or (null real-value) (eq real-value 'unspecified))
 245               nil)
 246              ((symbolp real-value)
 247               (list real-value))
 248              (t
 249               real-value)))
 250      ;; filter to make customized-value suitable for storing
 251      (lambda (cus-value)
 252        (if (and (consp cus-value) (null (cdr cus-value)))
 253            (car cus-value)
 254          cus-value))))
 255
 256   "Alist of face attributes.
 257
 258 The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
 259 where KEY is the name of the attribute, TYPE is a widget type for
 260 editing the attribute, PRE-FILTER is a function to make the attribute's
 261 value suitable for the customization widget, and POST-FILTER is a
 262 function to make the customized value suitable for storing.  PRE-FILTER
 263 and POST-FILTER are optional.
 264
 265 The PRE-FILTER should take a single argument, the attribute value as
 266 stored, and should return a value for customization (using the
 267 customization type TYPE).
 268
 269 The POST-FILTER should also take a single argument, the value after
 270 being customized, and should return a value suitable for setting the
 271 given face attribute.")
 272
 273
 274 (defun custom-face-attributes-get (face frame)
 275   "For FACE on FRAME, return an alternating list describing its attributes.
 276 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
 277 Each keyword should be listed in `custom-face-attributes'.
 278
 279 If FRAME is nil, use the global defaults for FACE."
 280   (let ((attrs custom-face-attributes)
 281         plist)
 282     (while attrs
 283       (let* ((attribute (car (car attrs)))
 284              (value (face-attribute face attribute frame)))
 285         (setq attrs (cdr attrs))
 286         (unless (or (eq value 'unspecified)
 287                     (and (null value) (memq attribute '(:inherit))))
 288           (setq plist (cons attribute (cons value plist))))))
 289     plist))
 290
 291 ;;; Initializing.
 292
 293 ;;;###autoload
 294 (defun custom-set-faces (&rest args)
 295   "Initialize faces according to user preferences.
 296 The arguments should be a list where each entry has the form:
 297
 298   (FACE SPEC [NOW [COMMENT]])
 299
 300 SPEC is stored as the saved value for FACE.
 301 If NOW is present and non-nil, FACE is created now, according to SPEC.
 302 COMMENT is a string comment about FACE.
 303
 304 See `defface' for the format of SPEC."
 305   (while args
 306     (let ((entry (car args)))
 307       (if (listp entry)
 308           (let ((face (nth 0 entry))
 309                 (spec (nth 1 entry))
 310                 (now (nth 2 entry))
 311                 (comment (nth 3 entry)))
 312             (put face 'saved-face spec)
 313             (put face 'saved-face-comment comment)
 314             (when now
 315               (put face 'force-face t))
 316             (when (or now (facep face))
 317               (put face 'face-comment comment)
 318               (make-empty-face face)
 319               (face-spec-set face spec))
 320             (setq args (cdr args)))
 321         ;; Old format, a plist of FACE SPEC pairs.
 322         (let ((face (nth 0 args))
 323               (spec (nth 1 args)))
 324           (put face 'saved-face spec))
 325         (setq args (cdr (cdr args)))))))
 326
 327 ;;; The End.
 328
 329 (provide 'cus-face)
 330
 331 ;;; cus-face.el ends here