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