code.delx.au - gnu-emacs/blob - 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        (let ((lwidth
 177               (or (and (consp real-value) (plist-get real-value :line-width))
 178                   (and (integerp real-value) real-value)
 179                   1))
 180              (color
 181               (or (and (consp real-value) (plist-get real-value :color))
 182                   (and (stringp real-value) real-value)
 183                   nil))
 184              (style
 185               (and (consp real-value) (plist-get real-value :style))))
 186          (list :line-width lwidth :color color :style style)))
 187      ;; filter to make customized-value suitable for storing
 188      (lambda (cus-value)
 189        (if (consp cus-value)
 190            (let ((lwidth (plist-get cus-value :line-width))
 191                  (color (plist-get cus-value :color))
 192                  (style (plist-get cus-value :style)))
 193              (cond ((and (null color) (null style))
 194                     lwidth)
 195                    ((and (null lwidth) (null style))
 196                     ;; actually can't happen, because LWIDTH is always an int
 197                     color)
 198                    (t
 199                     ;; Keep as a plist, but remove null entries
 200                     (nconc (and lwidth `(:line-width ,lwidth))
 201                            (and color  `(:color ,color))
 202                            (and style  `(:style ,style))))))
 203          cus-value)))
 204
 205     (:inverse-video
 206      (choice :tag "Inverse-video"
 207              :help-echo "Control whether text should be in inverse-video."
 208              (const :tag "*" nil)
 209              (const :tag "On" t)
 210              (const :tag "Off" off)))
 211
 212     (:foreground
 213      (choice :tag "Foreground"
 214              :help-echo "Set foreground color."
 215              (const :tag "*" nil)
 216              (color :tag "Color")))
 217
 218     (:background
 219      (choice :tag "Background"
 220              :help-echo "Set background color."
 221              (const :tag "*" nil)
 222              (color :tag "Color")))
 223
 224     (:stipple
 225      (choice :tag "Stipple"
 226              :help-echo "Background bit-mask"
 227              (const :tag "*" nil)
 228              (const :tag "None" off)
 229              (file :tag "File"
 230                    :help-echo "Name of bitmap file."
 231                    :must-match t)))
 232
 233     (:inherit
 234      (repeat :tag "Inherit"
 235              :help-echo "List of faces to inherit attributes from."
 236              (face :Tag "Face" default))
 237      ;; filter to make value suitable for customize
 238      (lambda (real-value)
 239        (cond ((or (null real-value) (eq real-value 'unspecified))
 240               nil)
 241              ((symbolp real-value)
 242               (list real-value))
 243              (t
 244               real-value)))
 245      ;; filter to make customized-value suitable for storing
 246      (lambda (cus-value)
 247        (if (and (consp cus-value) (null (cdr cus-value)))
 248            (car cus-value)
 249          cus-value))))
 250
 251   "Alist of face attributes.
 252
 253 The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
 254 where KEY is the name of the attribute, TYPE is a widget type for
 255 editing the attribute, PRE-FILTER is a function to make the attribute's
 256 value suitable for the customization widget, and POST-FILTER is a
 257 function to make the customized value suitable for storing.  PRE-FILTER
 258 and POST-FILTER are optional.
 259
 260 The PRE-FILTER should take a single argument, the attribute value as
 261 stored, and should return a value for customization (using the
 262 customization type TYPE).
 263
 264 The POST-FILTER should also take a single argument, the value after
 265 being customized, and should return a value suitable for setting the
 266 given face attribute.")
 267
 268
 269 (defun custom-face-attributes-get (face frame)
 270   "For FACE on FRAME, return an alternating list describing its attributes.
 271 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
 272 Each keyword should be listed in `custom-face-attributes'.
 273
 274 If FRAME is nil, use the global defaults for FACE."
 275   (let ((attrs custom-face-attributes)
 276         plist)
 277     (while attrs
 278       (let* ((attribute (car (car attrs)))
 279              (value (face-attribute face attribute frame)))
 280         (setq attrs (cdr attrs))
 281         (unless (or (eq value 'unspecified)
 282                     (and (null value) (memq attribute '(:inherit))))
 283           (setq plist (cons attribute (cons value plist))))))
 284     plist))
 285
 286 ;;; Initializing.
 287
 288 ;;;###autoload
 289 (defun custom-set-faces (&rest args)
 290   "Initialize faces according to user preferences.
 291 The arguments should be a list where each entry has the form:
 292
 293   (FACE SPEC [NOW [COMMENT]])
 294
 295 SPEC is stored as the saved value for FACE.
 296 If NOW is present and non-nil, FACE is created now, according to SPEC.
 297 COMMENT is a string comment about FACE.
 298
 299 See `defface' for the format of SPEC."
 300   (while args
 301     (let ((entry (car args)))
 302       (if (listp entry)
 303           (let ((face (nth 0 entry))
 304                 (spec (nth 1 entry))
 305                 (now (nth 2 entry))
 306                 (comment (nth 3 entry)))
 307             (put face 'saved-face spec)
 308             (put face 'saved-face-comment comment)
 309             (when now
 310               (put face 'force-face t))
 311             (when (or now (facep face))
 312               (put face 'face-comment comment)
 313               (make-empty-face face)
 314               (face-spec-set face spec))
 315             (setq args (cdr args)))
 316         ;; Old format, a plist of FACE SPEC pairs.
 317         (let ((face (nth 0 args))
 318               (spec (nth 1 args)))
 319           (put face 'saved-face spec))
 320         (setq args (cdr (cdr args)))))))
 321
 322 ;;; The End.
 323
 324 (provide 'cus-face)
 325
 326 ;;; cus-face.el ends here