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      (lambda (face value &optional frame)
 114        (set-face-attribute face frame :height (or value 'unspecified)))
 115      (lambda (face &optional frame)
 116        (let ((height (face-attribute face :height frame)))
 117          (if (eq height 'unspecified) nil height))))
 118
 119     (:weight
 120      (choice :tag "Weight"
 121              :help-echo "Font weight."
 122              (const :tag "*" nil)
 123              (const :tag "black" ultra_bold)
 124              (const :tag "bold" bold)
 125              (const :tag "book" semi-light)
 126              (const :tag "demibold" semi-bold)
 127              (const :tag "extralight" extra-light)
 128              (const :tag "extrabold" extra-bold)
 129              (const :tag "heavy" extra-bold)
 130              (const :tag "light" light)
 131              (const :tag "medium" normal)
 132              (const :tag "normal" normal)
 133              (const :tag "regular" normal)
 134              (const :tag "semibold" semi-bold)
 135              (const :tag "semilight" semi-light)
 136              (const :tag "ultralight" ultra-light)
 137              (const :tag "ultrabold" ultra-bold))
 138      (lambda (face value &optional frame)
 139        (set-face-attribute face frame :weight (or value 'unspecified)))
 140      (lambda (face &optional frame)
 141        (let ((weight (face-attribute face :weight frame)))
 142          (if (eq weight 'unspecified) nil weight))))
 143
 144     (:slant
 145      (choice :tag "Slant"
 146              :help-echo "Font slant."
 147              (const :tag "*" nil)
 148              (const :tag "italic" italic)
 149              (const :tag "oblique" oblique)
 150              (const :tag "normal" normal))
 151      (lambda (face value &optional frame)
 152        (set-face-attribute face frame :slant (or value 'unspecified)))
 153      (lambda (face &optional frame)
 154        (let ((slant (face-attribute face :slant frame)))
 155          (if (eq slant 'unspecified) nil slant))))
 156
 157     (:underline
 158      (choice :tag "Underline"
 159              :help-echo "Control text underlining."
 160              (const :tag "*" nil)
 161              (const :tag "On" t)
 162              (const :tag "Off" off)
 163              (color :tag "Colored"))
 164      (lambda (face value &optional frame)
 165        (cond ((eq value 'off) (setq value nil))
 166              ((null value) (setq value 'unspecified)))
 167        (set-face-attribute face frame :underline value))
 168      (lambda (face &optional frame)
 169        (let ((underline (face-attribute face :underline frame)))
 170          (cond ((eq underline 'unspecified) nil)
 171                ((null underline) 'off)))))
 172
 173     (:overline
 174      (choice :tag "Overline"
 175              :help-echo "Control text overlining."
 176              (const :tag "*" nil)
 177              (const :tag "On" t)
 178              (const :tag "Off" off)
 179              (color :tag "Colored"))
 180      (lambda (face value &optional frame)
 181        (cond ((eq value 'off) (setq value nil))
 182              ((null value) (setq value 'unspecified)))
 183        (set-face-attribute face frame :overline value))
 184      (lambda (face &optional frame)
 185        (let ((overline (face-attribute face :overline frame)))
 186          (cond ((eq overline 'unspecified) nil)
 187                ((null overline) 'off)))))
 188
 189     (:strike-through
 190      (choice :tag "Strike-through"
 191              :help-echo "Control text strike-through."
 192              (const :tag "*" nil)
 193              (const :tag "On" t)
 194              (const :tag "Off" off)
 195              (color :tag "Colored"))
 196      (lambda (face value &optional frame)
 197        (cond ((eq value 'off) (setq value nil))
 198              ((null value) (setq value 'unspecified)))
 199        (set-face-attribute face frame :strike-through value))
 200      (lambda (face &optional frame)
 201        (let ((value (face-attribute face :strike-through frame)))
 202          (cond ((eq value 'unspecified) (setq value nil))
 203                ((null value) (setq value 'off)))
 204          value)))
 205
 206     (:box
 207      ;; Fixme: this can probably be done better.
 208      (choice :tag "Box around text"
 209              :help-echo "Control box around text."
 210              (const :tag "*" t)
 211              (const :tag "Off" nil)
 212              (list :tag "Box"
 213                    :value (:line-width 2 :color "grey75"
 214                                        :style released-button)
 215                    (const :format "" :value :line-width)
 216                    (integer :tag "Width")
 217                    (const :format "" :value :color)
 218                    (choice :tag "Color" (const :tag "*" nil) color)
 219                    (const :format "" :value :style)
 220                    (choice :tag "Style"
 221                            (const :tag "Raised" released-button)
 222                            (const :tag "Sunken" pressed-button)
 223                            (const :tag "None" nil))))
 224      (lambda (face value &optional frame)
 225        (set-face-attribute face frame :box value))
 226      (lambda (face &optional frame)
 227        (let ((value (face-attribute face :box frame)))
 228          (if (consp value)
 229              (list :line-width (or (plist-get value :line-width) 1)
 230                    :color (plist-get value :color)
 231                    :style (plist-get value :style))
 232            value))))
 233
 234     (:inverse-video
 235      (choice :tag "Inverse-video"
 236              :help-echo "Control whether text should be in inverse-video."
 237              (const :tag "*" nil)
 238              (const :tag "On" t)
 239              (const :tag "Off" off))
 240      (lambda (face value &optional frame)
 241        (cond ((eq value 'off) (setq value nil))
 242              ((null value) (setq value 'unspecified)))
 243        (set-face-attribute face frame :inverse-video value))
 244      (lambda (face &optional frame)
 245        (let ((value (face-attribute face :inverse-video frame)))
 246          (cond ((eq value 'unspecified)
 247                 nil)
 248                ((null value)'off)))))
 249
 250     (:foreground
 251      (choice :tag "Foreground"
 252              :help-echo "Set foreground color."
 253              (const :tag "*" nil)
 254              (color :tag "Color"))
 255      (lambda (face value &optional frame)
 256        (set-face-attribute face frame :foreground (or value 'unspecified)))
 257      (lambda (face &optional frame)
 258        (let ((value (face-attribute face :foreground frame)))
 259          (if (eq value 'unspecified) nil value))))
 260
 261     (:background
 262      (choice :tag "Background"
 263              :help-echo "Set background color."
 264              (const :tag "*" nil)
 265              (color :tag "Color"))
 266      (lambda (face value &optional frame)
 267        (set-face-attribute face frame :background (or value 'unspecified)))
 268      (lambda (face &optional frame)
 269        (let ((value (face-attribute face :background frame)))
 270          (if (eq value 'unspecified) nil value))))
 271
 272     (:stipple
 273      (choice :tag "Stipple"
 274              :help-echo "Name of background bitmap file."
 275              (const :tag "*" nil)
 276              (file :tag "File" :must-match t))
 277      (lambda (face value &optional frame)
 278        (set-face-attribute face frame :stipple (or value 'unspecified)))
 279      (lambda (face &optional frame)
 280        (let ((value (face-attribute face :stipple frame)))
 281          (if (eq value 'unspecified) nil value)))))
 282
 283   "Alist of face attributes.
 284
 285 The elements are of the form (KEY TYPE SET GET), where KEY is the name
 286 of the attribute, TYPE is a widget type for editing the attibute, SET
 287 is a function for setting the attribute value, and GET is a function
 288 for getiing the attribute value.
 289
 290 The SET function should take three arguments, the face to modify, the
 291 value of the attribute, and optionally the frame where the face should
 292 be changed.
 293
 294 The GET function should take two arguments, the face to examine, and
 295 optionally the frame where the face should be examined.")
 296
 297
 298 (defun custom-face-attributes-get (face frame)
 299   "For FACE on FRAME, return an alternating list describing its attributes.
 300 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
 301 Each keyword should be listed in `custom-face-attributes'.
 302
 303 If FRAME is nil, use the global defaults for FACE."
 304   (let ((attrs custom-face-attributes)
 305         plist)
 306     (while attrs
 307       (let* ((attribute (car (car attrs)))
 308              (value (face-attribute face attribute frame)))
 309         (setq attrs (cdr attrs))
 310         (unless (eq value 'unspecified)
 311           (setq plist (cons attribute (cons value plist))))))
 312     plist))
 313
 314 ;;; Initializing.
 315
 316 ;;;###autoload
 317 (defun custom-set-faces (&rest args)
 318   "Initialize faces according to user preferences.
 319 The arguments should be a list where each entry has the form:
 320
 321   (FACE SPEC [NOW [COMMENT]])
 322
 323 SPEC is stored as the saved value for FACE.
 324 If NOW is present and non-nil, FACE is created now, according to SPEC.
 325 COMMENT is a string comment about FACE.
 326
 327 See `defface' for the format of SPEC."
 328   (while args
 329     (let ((entry (car args)))
 330       (if (listp entry)
 331           (let ((face (nth 0 entry))
 332                 (spec (nth 1 entry))
 333                 (now (nth 2 entry))
 334                 (comment (nth 3 entry)))
 335             (put face 'saved-face spec)
 336             (put face 'saved-face-comment comment)
 337             (when now
 338               (put face 'force-face t))
 339             (when (or now (facep face))
 340               (put face 'face-comment comment)
 341               (make-empty-face face)
 342               (face-spec-set face spec))
 343             (setq args (cdr args)))
 344         ;; Old format, a plist of FACE SPEC pairs.
 345         (let ((face (nth 0 args))
 346               (spec (nth 1 args)))
 347           (put face 'saved-face spec))
 348         (setq args (cdr (cdr args)))))))
 349
 350 ;;; The End.
 351
 352 (provide 'cus-face)
 353
 354 ;;; cus-face.el ends here