1 ;;; cus-face.el --- customization support for faces
3 ;; Copyright (C) 1996-1997, 1999-2011 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 3 of the License, or
14 ;; (at your option) any later version.
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. If not, see <http://www.gnu.org/licenses/>.
30 (defalias 'custom-facep
'facep
)
34 (defun custom-declare-face (face spec doc
&rest args
)
35 "Like `defface', but FACE is evaluated as a normal argument."
36 (unless (get face
'face-defface-spec
)
38 ;; If the user has already created the face, respect that.
39 (let ((value (or (get face
'saved-face
) spec
))
40 (have-window-system (memq initial-window-system
'(x w32
))))
41 ;; Create global face.
42 (make-empty-face face
)
43 ;; Create frame-local faces
44 (dolist (frame (frame-list))
45 (face-spec-set-2 face frame value
)
46 (when (memq (window-system frame
) '(x w32 ns
))
47 (setq have-window-system t
)))
48 ;; When making a face after frames already exist
49 (if have-window-system
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
(purecopy 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
)
58 ;; If the face has an existing theme setting, recalculate it.
59 (if (get face
'theme-face
)
60 (custom-theme-recalc-face face
)))
65 (defconst custom-face-attributes
67 (string :tag
"Font Family"
68 :help-echo
"Font family or fontset alias name."))
71 (string :tag
"Font Foundry"
72 :help-echo
"Font foundry name."))
76 :help-echo
"Font width."
77 :value normal
; default
78 (const :tag
"compressed" condensed
)
79 (const :tag
"condensed" condensed
)
80 (const :tag
"demiexpanded" semi-expanded
)
81 (const :tag
"expanded" expanded
)
82 (const :tag
"extracondensed" extra-condensed
)
83 (const :tag
"extraexpanded" extra-expanded
)
84 (const :tag
"medium" normal
)
85 (const :tag
"narrow" condensed
)
86 (const :tag
"normal" normal
)
87 (const :tag
"regular" normal
)
88 (const :tag
"semicondensed" semi-condensed
)
89 (const :tag
"semiexpanded" semi-expanded
)
90 (const :tag
"ultracondensed" ultra-condensed
)
91 (const :tag
"ultraexpanded" ultra-expanded
)
92 (const :tag
"wide" extra-expanded
)))
96 :help-echo
"Face's font height."
98 (integer :tag
"Height in 1/10 pt")
99 (number :tag
"Scale" 1.0)))
102 (choice :tag
"Weight"
103 :help-echo
"Font weight."
104 :value normal
; default
105 (const :tag
"black" ultra-bold
)
106 (const :tag
"bold" bold
)
107 (const :tag
"book" semi-light
)
108 (const :tag
"demibold" semi-bold
)
109 (const :tag
"extralight" extra-light
)
110 (const :tag
"extrabold" extra-bold
)
111 (const :tag
"heavy" extra-bold
)
112 (const :tag
"light" light
)
113 (const :tag
"medium" normal
)
114 (const :tag
"normal" normal
)
115 (const :tag
"regular" normal
)
116 (const :tag
"semibold" semi-bold
)
117 (const :tag
"semilight" semi-light
)
118 (const :tag
"ultralight" ultra-light
)
119 (const :tag
"ultrabold" ultra-bold
)
120 (const :tag
"thin" thin
)))
124 :help-echo
"Font slant."
125 :value normal
; default
126 (const :tag
"italic" italic
)
127 (const :tag
"oblique" oblique
)
128 (const :tag
"normal" normal
)
129 (const :tag
"roman" roman
)))
132 (choice :tag
"Underline"
133 :help-echo
"Control text underlining."
134 (const :tag
"Off" nil
)
136 (color :tag
"Colored")))
139 (choice :tag
"Overline"
140 :help-echo
"Control text overlining."
141 (const :tag
"Off" nil
)
143 (color :tag
"Colored")))
146 (choice :tag
"Strike-through"
147 :help-echo
"Control text strike-through."
148 (const :tag
"Off" nil
)
150 (color :tag
"Colored")))
153 ;; Fixme: this can probably be done better.
154 (choice :tag
"Box around text"
155 :help-echo
"Control box around text."
156 (const :tag
"Off" nil
)
158 :value
(:line-width
2 :color
"grey75" :style released-button
)
159 (const :format
"" :value
:line-width
)
160 (integer :tag
"Width")
161 (const :format
"" :value
:color
)
162 (choice :tag
"Color" (const :tag
"*" nil
) color
)
163 (const :format
"" :value
:style
)
165 (const :tag
"Raised" released-button
)
166 (const :tag
"Sunken" pressed-button
)
167 (const :tag
"None" nil
))))
168 ;; filter to make value suitable for customize
172 (or (and (consp real-value
)
173 (plist-get real-value
:line-width
))
174 (and (integerp real-value
) real-value
)
177 (or (and (consp real-value
) (plist-get real-value
:color
))
178 (and (stringp real-value
) real-value
)
181 (and (consp real-value
) (plist-get real-value
:style
))))
182 (list :line-width lwidth
:color color
:style style
))))
183 ;; filter to make customized-value suitable for storing
186 (let ((lwidth (plist-get cus-value
:line-width
))
187 (color (plist-get cus-value
:color
))
188 (style (plist-get cus-value
:style
)))
189 (cond ((and (null color
) (null style
))
191 ((and (null lwidth
) (null style
))
192 ;; actually can't happen, because LWIDTH is always an int
195 ;; Keep as a plist, but remove null entries
196 (nconc (and lwidth
`(:line-width
,lwidth
))
197 (and color
`(:color
,color
))
198 (and style
`(:style
,style
)))))))))
201 (choice :tag
"Inverse-video"
202 :help-echo
"Control whether text should be in inverse-video."
203 (const :tag
"Off" nil
)
204 (const :tag
"On" t
)))
207 (color :tag
"Foreground"
208 :help-echo
"Set foreground color (name or #RRGGBB hex spec)."))
211 (color :tag
"Background"
212 :help-echo
"Set background color (name or #RRGGBB hex spec)."))
215 (choice :tag
"Stipple"
216 :help-echo
"Background bit-mask"
217 (const :tag
"None" nil
)
219 :help-echo
"Name of bitmap file."
223 (repeat :tag
"Inherit"
224 :help-echo
"List of faces to inherit attributes from."
225 (face :Tag
"Face" default
))
226 ;; filter to make value suitable for customize
228 (cond ((or (null real-value
) (eq real-value
'unspecified
))
230 ((symbolp real-value
)
234 ;; filter to make customized-value suitable for storing
236 (if (and (consp cus-value
) (null (cdr cus-value
)))
240 "Alist of face attributes.
242 The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
243 where KEY is the name of the attribute, TYPE is a widget type for
244 editing the attribute, PRE-FILTER is a function to make the attribute's
245 value suitable for the customization widget, and POST-FILTER is a
246 function to make the customized value suitable for storing. PRE-FILTER
247 and POST-FILTER are optional.
249 The PRE-FILTER should take a single argument, the attribute value as
250 stored, and should return a value for customization (using the
251 customization type TYPE).
253 The POST-FILTER should also take a single argument, the value after
254 being customized, and should return a value suitable for setting the
255 given face attribute.")
257 (defun custom-face-attributes-get (face frame
)
258 "For FACE on FRAME, return an alternating list describing its attributes.
259 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
260 Each keyword should be listed in `custom-face-attributes'.
262 If FRAME is nil, use the global defaults for FACE."
263 (let ((attrs custom-face-attributes
)
266 (let* ((attribute (car (car attrs
)))
267 (value (face-attribute face attribute frame
)))
268 (setq attrs
(cdr attrs
))
269 (unless (or (eq value
'unspecified
)
270 (and (null value
) (memq attribute
'(:inherit
))))
271 (setq plist
(cons attribute
(cons value plist
))))))
276 (defun custom-set-faces (&rest args
)
277 "Initialize faces according to user preferences.
278 This associates the settings with the `user' theme.
279 The arguments should be a list where each entry has the form:
281 (FACE SPEC [NOW [COMMENT]])
283 SPEC is stored as the saved value for FACE, as well as the value for the
284 `user' theme. The `user' theme is one of the default themes known to Emacs.
285 See `custom-known-themes' for more information on the known themes.
286 See `custom-theme-set-faces' for more information on the interplay
287 between themes and faces.
288 See `defface' for the format of SPEC.
290 If NOW is present and non-nil, FACE is created now, according to SPEC.
291 COMMENT is a string comment about FACE."
292 (apply 'custom-theme-set-faces
'user args
))
294 (defun custom-theme-set-faces (theme &rest args
)
295 "Initialize faces for theme THEME.
296 The arguments should be a list where each entry has the form:
298 (FACE SPEC [NOW [COMMENT]])
300 SPEC is stored as the saved value for FACE, as well as the value for the
301 `user' theme. The `user' theme is one of the default themes known to Emacs.
302 See `custom-known-themes' for more information on the known themes.
303 See `custom-theme-set-faces' for more information on the interplay
304 between themes and faces.
305 See `defface' for the format of SPEC.
307 If NOW is present and non-nil, FACE is created now, according to SPEC.
308 COMMENT is a string comment about FACE.
310 Several properties of THEME and FACE are used in the process:
312 If THEME property `theme-immediate' is non-nil, this is equivalent of
313 providing the NOW argument to all faces in the argument list: FACE is
314 created now. The only difference is FACE property `force-face': if NOW
315 is non-nil, FACE property `force-face' is set to the symbol `rogue', else
316 if THEME property `theme-immediate' is non-nil, FACE property `force-face'
317 is set to the symbol `immediate'.
319 SPEC itself is saved in FACE property `saved-face' and it is stored in
320 FACE's list property `theme-face' \(using `custom-push-theme')."
321 (custom-check-theme theme
)
322 (let ((immediate (get theme
'theme-immediate
)))
324 (unless (listp entry
)
325 (error "Incompatible Custom theme spec"))
326 (let ((face (car entry
))
327 (spec (nth 1 entry
)))
328 ;; If FACE is actually an alias, customize the face it
330 (if (get face
'face-alias
)
331 (setq face
(get face
'face-alias
)))
332 (if custom--inhibit-theme-enable
333 ;; Just update theme settings.
334 (custom-push-theme 'theme-face face theme
'set spec
)
335 ;; Update theme settings and set the face spec.
336 (let ((now (nth 2 entry
))
337 (comment (nth 3 entry
))
338 (oldspec (get face
'theme-face
)))
339 (when (not (and oldspec
(eq 'user
(caar oldspec
))))
340 (put face
'saved-face spec
)
341 (put face
'saved-face-comment comment
))
342 ;; Do this AFTER checking the `theme-face' property.
343 (custom-push-theme 'theme-face face theme
'set spec
)
344 (when (or now immediate
)
345 (put face
'force-face
(if now
'rogue
'immediate
)))
346 (when (or now immediate
(facep face
))
348 (make-empty-face face
))
349 (put face
'face-comment comment
)
350 (put face
'face-override-spec nil
)
351 (face-spec-set face spec t
))))))))
353 ;; XEmacs compatibility function. In XEmacs, when you reset a Custom
354 ;; Theme, you have to specify the theme to reset it to. We just apply
356 (defun custom-theme-reset-faces (theme &rest args
)
357 "Reset the specs in THEME of some faces to their specs in other themes.
358 Each of the arguments ARGS has this form:
362 This means reset FACE. The argument IGNORED is ignored."
363 (custom-check-theme theme
)
365 (custom-push-theme 'theme-face
(car arg
) theme
'reset
)))
367 (defun custom-reset-faces (&rest args
)
368 "Reset the specs of some faces to their specs in specified themes.
369 This creates settings in the `user' theme.
371 Each of the arguments ARGS has this form:
375 This means reset FACE to its value in FROM-THEME."
376 (apply 'custom-theme-reset-faces
'user args
))
382 ;;; cus-face.el ends here