1 ;;; cus-face.el --- customization support for faces
3 ;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Keywords: help, faces
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
31 (defalias 'custom-facep
'facep
)
36 (defun custom-declare-face (face spec doc
&rest args
)
37 "Like `defface', but FACE is evaluated as a normal argument."
38 (unless (get face
'face-defface-spec
)
39 (when (fboundp 'facep
)
41 ;; If the user has already created the face, respect that.
42 (let ((value (or (get face
'saved-face
) spec
)))
43 ;; Create global face.
44 (make-empty-face face
)
45 ;; Create frame-local faces
46 (dolist (frame (frame-list))
47 (face-spec-set face value frame
)))
48 ;; When making a face after frames already exist
49 (if (memq window-system
'(x w32
))
50 (make-face-x-resource-internal face
))))
51 ;; Don't record SPEC until we see it causes no errors.
52 (put face
'face-defface-spec spec
)
53 (push (cons 'defface face
) current-load-list
)
54 (when (and doc
(null (face-documentation face
)))
55 (set-face-documentation face
(purecopy doc
)))
56 (custom-handle-all-keywords face args
'custom-face
)
57 (run-hooks 'custom-define-hook
))
62 (defconst custom-face-attributes
64 (string :tag
"Font Family"
65 :help-echo
"Font family or fontset alias name."))
69 :help-echo
"Font width."
70 :value normal
; default
71 (const :tag
"compressed" condensed
)
72 (const :tag
"condensed" condensed
)
73 (const :tag
"demiexpanded" semi-expanded
)
74 (const :tag
"expanded" expanded
)
75 (const :tag
"extracondensed" extra-condensed
)
76 (const :tag
"extraexpanded" extra-expanded
)
77 (const :tag
"medium" normal
)
78 (const :tag
"narrow" condensed
)
79 (const :tag
"normal" normal
)
80 (const :tag
"regular" normal
)
81 (const :tag
"semicondensed" semi-condensed
)
82 (const :tag
"semiexpanded" semi-expanded
)
83 (const :tag
"ultracondensed" ultra-condensed
)
84 (const :tag
"ultraexpanded" ultra-expanded
)
85 (const :tag
"wide" extra-expanded
)))
89 :help-echo
"Face's font height."
91 (integer :tag
"Height in 1/10 pt")
92 (number :tag
"Scale" 1.0)))
96 :help-echo
"Font weight."
97 :value normal
; default
98 (const :tag
"black" ultra-bold
)
99 (const :tag
"bold" bold
)
100 (const :tag
"book" semi-light
)
101 (const :tag
"demibold" semi-bold
)
102 (const :tag
"extralight" extra-light
)
103 (const :tag
"extrabold" extra-bold
)
104 (const :tag
"heavy" extra-bold
)
105 (const :tag
"light" light
)
106 (const :tag
"medium" normal
)
107 (const :tag
"normal" normal
)
108 (const :tag
"regular" normal
)
109 (const :tag
"semibold" semi-bold
)
110 (const :tag
"semilight" semi-light
)
111 (const :tag
"ultralight" ultra-light
)
112 (const :tag
"ultrabold" ultra-bold
)))
116 :help-echo
"Font slant."
117 :value normal
; default
118 (const :tag
"italic" italic
)
119 (const :tag
"oblique" oblique
)
120 (const :tag
"normal" normal
)))
123 (choice :tag
"Underline"
124 :help-echo
"Control text underlining."
125 (const :tag
"Off" nil
)
127 (color :tag
"Colored")))
130 (choice :tag
"Overline"
131 :help-echo
"Control text overlining."
132 (const :tag
"Off" nil
)
134 (color :tag
"Colored")))
137 (choice :tag
"Strike-through"
138 :help-echo
"Control text strike-through."
139 (const :tag
"Off" nil
)
141 (color :tag
"Colored")))
144 ;; Fixme: this can probably be done better.
145 (choice :tag
"Box around text"
146 :help-echo
"Control box around text."
147 (const :tag
"Off" nil
)
149 :value
(:line-width
2 :color
"grey75" :style released-button
)
150 (const :format
"" :value
:line-width
)
151 (integer :tag
"Width")
152 (const :format
"" :value
:color
)
153 (choice :tag
"Color" (const :tag
"*" nil
) color
)
154 (const :format
"" :value
:style
)
156 (const :tag
"Raised" released-button
)
157 (const :tag
"Sunken" pressed-button
)
158 (const :tag
"None" nil
))))
159 ;; filter to make value suitable for customize
163 (or (and (consp real-value
)
164 (plist-get real-value
:line-width
))
165 (and (integerp real-value
) real-value
)
168 (or (and (consp real-value
) (plist-get real-value
:color
))
169 (and (stringp real-value
) real-value
)
172 (and (consp real-value
) (plist-get real-value
:style
))))
173 (list :line-width lwidth
:color color
:style style
))))
174 ;; filter to make customized-value suitable for storing
177 (let ((lwidth (plist-get cus-value
:line-width
))
178 (color (plist-get cus-value
:color
))
179 (style (plist-get cus-value
:style
)))
180 (cond ((and (null color
) (null style
))
182 ((and (null lwidth
) (null style
))
183 ;; actually can't happen, because LWIDTH is always an int
186 ;; Keep as a plist, but remove null entries
187 (nconc (and lwidth
`(:line-width
,lwidth
))
188 (and color
`(:color
,color
))
189 (and style
`(:style
,style
)))))))))
192 (choice :tag
"Inverse-video"
193 :help-echo
"Control whether text should be in inverse-video."
194 (const :tag
"Off" nil
)
195 (const :tag
"On" t
)))
198 (color :tag
"Foreground"
199 :help-echo
"Set foreground color (name or #RRGGBB hex spec)."))
202 (color :tag
"Background"
203 :help-echo
"Set background color (name or #RRGGBB hex spec)."))
206 (choice :tag
"Stipple"
207 :help-echo
"Background bit-mask"
208 (const :tag
"None" nil
)
210 :help-echo
"Name of bitmap file."
214 (repeat :tag
"Inherit"
215 :help-echo
"List of faces to inherit attributes from."
216 (face :Tag
"Face" default
))
217 ;; filter to make value suitable for customize
219 (cond ((or (null real-value
) (eq real-value
'unspecified
))
221 ((symbolp real-value
)
225 ;; filter to make customized-value suitable for storing
227 (if (and (consp cus-value
) (null (cdr cus-value
)))
231 "Alist of face attributes.
233 The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
234 where KEY is the name of the attribute, TYPE is a widget type for
235 editing the attribute, PRE-FILTER is a function to make the attribute's
236 value suitable for the customization widget, and POST-FILTER is a
237 function to make the customized value suitable for storing. PRE-FILTER
238 and POST-FILTER are optional.
240 The PRE-FILTER should take a single argument, the attribute value as
241 stored, and should return a value for customization (using the
242 customization type TYPE).
244 The POST-FILTER should also take a single argument, the value after
245 being customized, and should return a value suitable for setting the
246 given face attribute.")
248 (defun custom-face-attributes-get (face frame
)
249 "For FACE on FRAME, return an alternating list describing its attributes.
250 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
251 Each keyword should be listed in `custom-face-attributes'.
253 If FRAME is nil, use the global defaults for FACE."
254 (let ((attrs custom-face-attributes
)
257 (let* ((attribute (car (car attrs
)))
258 (value (face-attribute face attribute frame
)))
259 (setq attrs
(cdr attrs
))
260 (unless (or (eq value
'unspecified
)
261 (and (null value
) (memq attribute
'(:inherit
))))
262 (setq plist
(cons attribute
(cons value plist
))))))
268 (defun custom-set-faces (&rest args
)
269 "Initialize faces according to user preferences.
270 This associates the settings with the `user' theme.
271 The arguments should be a list where each entry has the form:
273 (FACE SPEC [NOW [COMMENT]])
275 SPEC is stored as the saved value for FACE, as well as the value for the
276 `user' theme. The `user' theme is one of the default themes known to Emacs.
277 See `custom-known-themes' for more information on the known themes.
278 See `custom-theme-set-faces' for more information on the interplay
279 between themes and faces.
280 See `defface' for the format of SPEC.
282 If NOW is present and non-nil, FACE is created now, according to SPEC.
283 COMMENT is a string comment about FACE."
284 (apply 'custom-theme-set-faces
'user args
))
286 (defun custom-theme-set-faces (theme &rest args
)
287 "Initialize faces for theme THEME.
288 The arguments should be a list where each entry has the form:
290 (FACE SPEC [NOW [COMMENT]])
292 SPEC is stored as the saved value for FACE, as well as the value for the
293 `user' theme. The `user' theme is one of the default themes known to Emacs.
294 See `custom-known-themes' for more information on the known themes.
295 See `custom-theme-set-faces' for more information on the interplay
296 between themes and faces.
297 See `defface' for the format of SPEC.
299 If NOW is present and non-nil, FACE is created now, according to SPEC.
300 COMMENT is a string comment about FACE.
302 Several properties of THEME and FACE are used in the process:
304 If THEME property `theme-immediate' is non-nil, this is equivalent of
305 providing the NOW argument to all faces in the argument list: FACE is
306 created now. The only difference is FACE property `force-face': if NOW
307 is non-nil, FACE property `force-face' is set to the symbol `rogue', else
308 if THEME property `theme-immediate' is non-nil, FACE property `force-face'
309 is set to the symbol `immediate'.
311 SPEC itself is saved in FACE property `saved-face' and it is stored in
312 FACE's list property `theme-face' \(using `custom-push-theme')."
313 (custom-check-theme theme
)
314 (let ((immediate (get theme
'theme-immediate
)))
316 (let ((entry (car args
)))
318 (let ((face (nth 0 entry
))
321 (comment (nth 3 entry
)))
322 (put face
'saved-face spec
)
323 (put face
'saved-face-comment comment
)
324 (custom-push-theme 'theme-face face theme
'set spec
)
325 (when (or now immediate
)
326 (put face
'force-face
(if now
'rogue
'immediate
)))
327 (when (or now immediate
(facep face
))
329 (make-empty-face face
))
330 (put face
'face-comment comment
)
331 (face-spec-set face spec
))
332 (setq args
(cdr args
)))
333 ;; Old format, a plist of FACE SPEC pairs.
334 (let ((face (nth 0 args
))
336 (put face
'saved-face spec
)
337 (custom-push-theme 'theme-face face theme
'set spec
))
338 (setq args
(cdr (cdr args
))))))))
341 (defun custom-theme-face-value (face theme
)
342 "Return spec of FACE in THEME if THEME modifies FACE.
343 Value is nil otherwise. The association between theme and spec for FACE
344 is stored in FACE's property `theme-face'. The appropriate face
345 is retrieved using `custom-theme-value'."
346 ;; Returns car because the value is stored inside a one element list
347 (car-safe (custom-theme-value theme
(get face
'theme-face
))))
349 (defun custom-theme-reset-internal-face (face to-theme
)
350 "Reset FACE to the value defined by TO-THEME.
351 If FACE is not defined in TO-THEME, reset FACE to the standard
352 value. See `custom-theme-face-value'. The standard value is
353 stored in SYMBOL's property `face-defface-spec' by `defface'."
354 (let ((spec (custom-theme-face-value face to-theme
))
356 (setq was-in-theme spec
)
357 (setq spec
(or spec
(get face
'face-defface-spec
)))
359 (put face
'save-face was-in-theme
)
360 (when (or (get face
'force-face
) (facep face
))
362 (make-empty-face face
))
363 (face-spec-set face spec
)))
367 (defun custom-theme-reset-faces (theme &rest args
)
368 "Reset the value of the face to values previously defined.
369 Associate this setting with THEME.
371 ARGS is a list of lists of the form
375 This means reset FACE to its value in TO-THEME."
376 (custom-check-theme theme
)
377 (mapcar '(lambda (arg)
378 (apply 'custom-theme-reset-internal-face arg
)
379 (custom-push-theme 'theme-face
(car arg
) theme
'reset
(cadr arg
)))
383 (defun custom-reset-faces (&rest args
)
384 "Reset the value of the face to values previously saved.
385 This is the setting assosiated the `user' theme.
387 ARGS is defined as for `custom-theme-reset-faces'"
388 (apply 'custom-theme-reset-faces
'user args
))
394 ;;; arch-tag: 9a5c4b63-0d27-4c92-a5af-f2c7ed764c2b
395 ;;; cus-face.el ends here