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
))
63 (defconst custom-face-attributes
65 (string :tag
"Font Family"
66 :help-echo
"Font family or fontset alias name."))
70 :help-echo
"Font width."
71 :value normal
; default
72 (const :tag
"compressed" condensed
)
73 (const :tag
"condensed" condensed
)
74 (const :tag
"demiexpanded" semi-expanded
)
75 (const :tag
"expanded" expanded
)
76 (const :tag
"extracondensed" extra-condensed
)
77 (const :tag
"extraexpanded" extra-expanded
)
78 (const :tag
"medium" normal
)
79 (const :tag
"narrow" condensed
)
80 (const :tag
"normal" normal
)
81 (const :tag
"regular" normal
)
82 (const :tag
"semicondensed" semi-condensed
)
83 (const :tag
"semiexpanded" semi-expanded
)
84 (const :tag
"ultracondensed" ultra-condensed
)
85 (const :tag
"ultraexpanded" ultra-expanded
)
86 (const :tag
"wide" extra-expanded
)))
90 :help-echo
"Face's font height."
92 (integer :tag
"Height in 1/10 pt")
93 (number :tag
"Scale" 1.0)))
97 :help-echo
"Font weight."
98 :value normal
; default
99 (const :tag
"black" ultra-bold
)
100 (const :tag
"bold" bold
)
101 (const :tag
"book" semi-light
)
102 (const :tag
"demibold" semi-bold
)
103 (const :tag
"extralight" extra-light
)
104 (const :tag
"extrabold" extra-bold
)
105 (const :tag
"heavy" extra-bold
)
106 (const :tag
"light" light
)
107 (const :tag
"medium" normal
)
108 (const :tag
"normal" normal
)
109 (const :tag
"regular" normal
)
110 (const :tag
"semibold" semi-bold
)
111 (const :tag
"semilight" semi-light
)
112 (const :tag
"ultralight" ultra-light
)
113 (const :tag
"ultrabold" ultra-bold
)))
117 :help-echo
"Font slant."
118 :value normal
; default
119 (const :tag
"italic" italic
)
120 (const :tag
"oblique" oblique
)
121 (const :tag
"normal" normal
)))
124 (choice :tag
"Underline"
125 :help-echo
"Control text underlining."
126 (const :tag
"Off" nil
)
128 (color :tag
"Colored")))
131 (choice :tag
"Overline"
132 :help-echo
"Control text overlining."
133 (const :tag
"Off" nil
)
135 (color :tag
"Colored")))
138 (choice :tag
"Strike-through"
139 :help-echo
"Control text strike-through."
140 (const :tag
"Off" nil
)
142 (color :tag
"Colored")))
145 ;; Fixme: this can probably be done better.
146 (choice :tag
"Box around text"
147 :help-echo
"Control box around text."
148 (const :tag
"Off" nil
)
150 :value
(:line-width
2 :color
"grey75" :style released-button
)
151 (const :format
"" :value
:line-width
)
152 (integer :tag
"Width")
153 (const :format
"" :value
:color
)
154 (choice :tag
"Color" (const :tag
"*" nil
) color
)
155 (const :format
"" :value
:style
)
157 (const :tag
"Raised" released-button
)
158 (const :tag
"Sunken" pressed-button
)
159 (const :tag
"None" nil
))))
160 ;; filter to make value suitable for customize
164 (or (and (consp real-value
)
165 (plist-get real-value
:line-width
))
166 (and (integerp real-value
) real-value
)
169 (or (and (consp real-value
) (plist-get real-value
:color
))
170 (and (stringp real-value
) real-value
)
173 (and (consp real-value
) (plist-get real-value
:style
))))
174 (list :line-width lwidth
:color color
:style style
))))
175 ;; filter to make customized-value suitable for storing
178 (let ((lwidth (plist-get cus-value
:line-width
))
179 (color (plist-get cus-value
:color
))
180 (style (plist-get cus-value
:style
)))
181 (cond ((and (null color
) (null style
))
183 ((and (null lwidth
) (null style
))
184 ;; actually can't happen, because LWIDTH is always an int
187 ;; Keep as a plist, but remove null entries
188 (nconc (and lwidth
`(:line-width
,lwidth
))
189 (and color
`(:color
,color
))
190 (and style
`(:style
,style
)))))))))
193 (choice :tag
"Inverse-video"
194 :help-echo
"Control whether text should be in inverse-video."
195 (const :tag
"Off" nil
)
196 (const :tag
"On" t
)))
199 (color :tag
"Foreground"
200 :help-echo
"Set foreground color (name or #RRGGBB hex spec)."))
203 (color :tag
"Background"
204 :help-echo
"Set background color (name or #RRGGBB hex spec)."))
207 (choice :tag
"Stipple"
208 :help-echo
"Background bit-mask"
209 (const :tag
"None" nil
)
211 :help-echo
"Name of bitmap file."
215 (repeat :tag
"Inherit"
216 :help-echo
"List of faces to inherit attributes from."
217 (face :Tag
"Face" default
))
218 ;; filter to make value suitable for customize
220 (cond ((or (null real-value
) (eq real-value
'unspecified
))
222 ((symbolp real-value
)
226 ;; filter to make customized-value suitable for storing
228 (if (and (consp cus-value
) (null (cdr cus-value
)))
232 "Alist of face attributes.
234 The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
235 where KEY is the name of the attribute, TYPE is a widget type for
236 editing the attribute, PRE-FILTER is a function to make the attribute's
237 value suitable for the customization widget, and POST-FILTER is a
238 function to make the customized value suitable for storing. PRE-FILTER
239 and POST-FILTER are optional.
241 The PRE-FILTER should take a single argument, the attribute value as
242 stored, and should return a value for customization (using the
243 customization type TYPE).
245 The POST-FILTER should also take a single argument, the value after
246 being customized, and should return a value suitable for setting the
247 given face attribute.")
249 (defun custom-face-attributes-get (face frame
)
250 "For FACE on FRAME, return an alternating list describing its attributes.
251 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
252 Each keyword should be listed in `custom-face-attributes'.
254 If FRAME is nil, use the global defaults for FACE."
255 (let ((attrs custom-face-attributes
)
258 (let* ((attribute (car (car attrs
)))
259 (value (face-attribute face attribute frame
)))
260 (setq attrs
(cdr attrs
))
261 (unless (or (eq value
'unspecified
)
262 (and (null value
) (memq attribute
'(:inherit
))))
263 (setq plist
(cons attribute
(cons value plist
))))))
269 (defun custom-set-faces (&rest args
)
270 "Initialize faces according to user preferences.
271 This associates the settings with the `user' theme.
272 The arguments should be a list where each entry has the form:
274 (FACE SPEC [NOW [COMMENT]])
276 SPEC is stored as the saved value for FACE, as well as the value for the
277 `user' theme. The `user' theme is one of the default themes known to Emacs.
278 See `custom-known-themes' for more information on the known themes.
279 See `custom-theme-set-faces' for more information on the interplay
280 between themes and faces.
281 See `defface' for the format of SPEC.
283 If NOW is present and non-nil, FACE is created now, according to SPEC.
284 COMMENT is a string comment about FACE."
285 (apply 'custom-theme-set-faces
'user args
))
287 (defun custom-theme-set-faces (theme &rest args
)
288 "Initialize faces for theme THEME.
289 The arguments should be a list where each entry has the form:
291 (FACE SPEC [NOW [COMMENT]])
293 SPEC is stored as the saved value for FACE, as well as the value for the
294 `user' theme. The `user' theme is one of the default themes known to Emacs.
295 See `custom-known-themes' for more information on the known themes.
296 See `custom-theme-set-faces' for more information on the interplay
297 between themes and faces.
298 See `defface' for the format of SPEC.
300 If NOW is present and non-nil, FACE is created now, according to SPEC.
301 COMMENT is a string comment about FACE.
303 Several properties of THEME and FACE are used in the process:
305 If THEME property `theme-immediate' is non-nil, this is equivalent of
306 providing the NOW argument to all faces in the argument list: FACE is
307 created now. The only difference is FACE property `force-face': if NOW
308 is non-nil, FACE property `force-face' is set to the symbol `rogue', else
309 if THEME property `theme-immediate' is non-nil, FACE property `force-face'
310 is set to the symbol `immediate'.
312 SPEC itself is saved in FACE property `saved-face' and it is stored in
313 FACE's list property `theme-face' \(using `custom-push-theme')."
314 (custom-check-theme theme
)
315 (let ((immediate (get theme
'theme-immediate
)))
317 (let ((entry (car args
)))
319 (let ((face (nth 0 entry
))
322 (comment (nth 3 entry
)))
323 ;; If FACE is actually an alias, customize the face it
325 (if (get face
'face-alias
)
326 (setq face
(get face
'face-alias
)))
327 (put face
'saved-face spec
)
328 (put face
'saved-face-comment comment
)
329 (custom-push-theme 'theme-face face theme
'set spec
)
330 (when (or now immediate
)
331 (put face
'force-face
(if now
'rogue
'immediate
)))
332 (when (or now immediate
(facep face
))
334 (make-empty-face face
))
335 (put face
'face-comment comment
)
336 (face-spec-set face spec
))
337 (setq args
(cdr args
)))
338 ;; Old format, a plist of FACE SPEC pairs.
339 (let ((face (nth 0 args
))
341 (if (get face
'face-alias
)
342 (setq face
(get face
'face-alias
)))
343 (put face
'saved-face spec
)
344 (custom-push-theme 'theme-face face theme
'set spec
))
345 (setq args
(cdr (cdr args
))))))))
348 (defun custom-theme-face-value (face theme
)
349 "Return spec of FACE in THEME if THEME modifies FACE.
350 Value is nil otherwise. The association between theme and spec for FACE
351 is stored in FACE's property `theme-face'. The appropriate face
352 is retrieved using `custom-theme-value'."
353 ;; Returns car because the value is stored inside a one element list
354 (car-safe (custom-theme-value theme
(get face
'theme-face
))))
356 (defun custom-theme-reset-internal-face (face to-theme
)
357 "Reset FACE to the value defined by TO-THEME.
358 If FACE is not defined in TO-THEME, reset FACE to the standard
359 value. See `custom-theme-face-value'. The standard value is
360 stored in SYMBOL's property `face-defface-spec' by `defface'."
361 (let ((spec (custom-theme-face-value face to-theme
))
363 (setq was-in-theme spec
)
364 (setq spec
(or spec
(get face
'face-defface-spec
)))
366 (put face
'save-face was-in-theme
)
367 (when (or (get face
'force-face
) (facep face
))
369 (make-empty-face face
))
370 (face-spec-set face spec
)))
374 (defun custom-theme-reset-faces (theme &rest args
)
375 "Reset the value of the face to values previously defined.
376 Associate this setting with THEME.
378 ARGS is a list of lists of the form
382 This means reset FACE to its value in TO-THEME."
383 (custom-check-theme theme
)
384 (mapcar '(lambda (arg)
385 (apply 'custom-theme-reset-internal-face arg
)
386 (custom-push-theme 'theme-face
(car arg
) theme
'reset
(cadr arg
)))
390 (defun custom-reset-faces (&rest args
)
391 "Reset the value of the face to values previously saved.
392 This is the setting assosiated the `user' theme.
394 ARGS is defined as for `custom-theme-reset-faces'"
395 (apply 'custom-theme-reset-faces
'user args
))
401 ;;; arch-tag: 9a5c4b63-0d27-4c92-a5af-f2c7ed764c2b
402 ;;; cus-face.el ends here