1 ;;; cus-face.el --- customization support for faces
3 ;; Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation, Inc.
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Keywords: help, faces
9 ;; This file is part of GNU Emacs.
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)
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.
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.
32 (defalias 'custom-facep 'facep)
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)
43 ;; If the user has already created the face, respect that.
44 (let ((value (or (get face 'saved-face) spec))
47 ;; Create global face.
48 (make-empty-face face)
49 ;; Create frame local faces
51 (setq frame (car 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))
65 (defconst custom-face-attributes
67 (string :tag "Font Family"
68 :help-echo "Font family or fontset alias name."))
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)))
92 :help-echo "Face's font height."
94 (integer :tag "Height in 1/10 pt")
95 (number :tag "Scale" 1.0)))
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)))
119 :help-echo "Font slant."
120 :value normal ; default
121 (const :tag "italic" italic)
122 (const :tag "oblique" oblique)
123 (const :tag "normal" normal)))
126 (choice :tag "Underline"
127 :help-echo "Control text underlining."
128 (const :tag "Off" nil)
130 (color :tag "Colored")))
133 (choice :tag "Overline"
134 :help-echo "Control text overlining."
135 (const :tag "Off" nil)
137 (color :tag "Colored")))
140 (choice :tag "Strike-through"
141 :help-echo "Control text strike-through."
142 (const :tag "Off" nil)
144 (color :tag "Colored")))
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)
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)
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
166 (or (and (consp real-value)
167 (plist-get real-value :line-width))
168 (and (integerp real-value) real-value)
171 (or (and (consp real-value) (plist-get real-value :color))
172 (and (stringp real-value) real-value)
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
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))
185 ((and (null lwidth) (null style))
186 ;; actually can't happen, because LWIDTH is always an int
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)))))))))
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)))
201 (color :tag "Foreground"
202 :help-echo "Set foreground color."))
205 (color :tag "Background"
206 :help-echo "Set background color."))
209 (choice :tag "Stipple"
210 :help-echo "Background bit-mask"
211 (const :tag "None" nil)
213 :help-echo "Name of bitmap file."
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
222 (cond ((or (null real-value) (eq real-value 'unspecified))
224 ((symbolp real-value)
228 ;; filter to make customized-value suitable for storing
230 (if (and (consp cus-value) (null (cdr cus-value)))
234 "Alist of face attributes.
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.
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).
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.")
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'.
257 If FRAME is nil, use the global defaults for FACE."
258 (let ((attrs custom-face-attributes)
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))))))
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:
276 (FACE SPEC [NOW [COMMENT]])
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.
282 See `defface' for the format of SPEC."
284 (let ((entry (car args)))
286 (let ((face (nth 0 entry))
289 (comment (nth 3 entry)))
290 (put face 'saved-face spec)
291 (put face 'saved-face-comment comment)
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))
302 (put face 'saved-face spec))
303 (setq args (cdr (cdr args)))))))
309 ;;; cus-face.el ends here