1 ;;; cus-face.el --- customization support for faces
3 ;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007 Free Software Foundation, Inc.
6 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
7 ;; 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, 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., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, 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 (when (fboundp 'facep
)
42 ;; If the user has already created the face, respect that.
43 (let ((value (or (get face
'saved-face
) spec
))
44 (have-window-system (memq initial-window-system
'(x w32
))))
45 ;; Create global face.
46 (make-empty-face face
)
47 ;; Create frame-local faces
48 (dolist (frame (frame-list))
49 (face-spec-set face value frame
)
50 (when (memq (window-system frame
) '(x w32 mac
))
51 (setq have-window-system t
)))
52 ;; When making a face after frames already exist
53 (if have-window-system
54 (make-face-x-resource-internal face
)))))
55 ;; Don't record SPEC until we see it causes no errors.
56 (put face
'face-defface-spec spec
)
57 (push (cons 'defface face
) current-load-list
)
58 (when (and doc
(null (face-documentation face
)))
59 (set-face-documentation face
(purecopy doc
)))
60 (custom-handle-all-keywords face args
'custom-face
)
61 (run-hooks 'custom-define-hook
))
67 (defconst custom-face-attributes
69 (string :tag
"Font Family"
70 :help-echo
"Font family or fontset alias name."))
74 :help-echo
"Font width."
75 :value normal
; default
76 (const :tag
"compressed" condensed
)
77 (const :tag
"condensed" condensed
)
78 (const :tag
"demiexpanded" semi-expanded
)
79 (const :tag
"expanded" expanded
)
80 (const :tag
"extracondensed" extra-condensed
)
81 (const :tag
"extraexpanded" extra-expanded
)
82 (const :tag
"medium" normal
)
83 (const :tag
"narrow" condensed
)
84 (const :tag
"normal" normal
)
85 (const :tag
"regular" normal
)
86 (const :tag
"semicondensed" semi-condensed
)
87 (const :tag
"semiexpanded" semi-expanded
)
88 (const :tag
"ultracondensed" ultra-condensed
)
89 (const :tag
"ultraexpanded" ultra-expanded
)
90 (const :tag
"wide" extra-expanded
)))
94 :help-echo
"Face's font height."
96 (integer :tag
"Height in 1/10 pt")
97 (number :tag
"Scale" 1.0)))
100 (choice :tag
"Weight"
101 :help-echo
"Font weight."
102 :value normal
; default
103 (const :tag
"black" ultra-bold
)
104 (const :tag
"bold" bold
)
105 (const :tag
"book" semi-light
)
106 (const :tag
"demibold" semi-bold
)
107 (const :tag
"extralight" extra-light
)
108 (const :tag
"extrabold" extra-bold
)
109 (const :tag
"heavy" extra-bold
)
110 (const :tag
"light" light
)
111 (const :tag
"medium" normal
)
112 (const :tag
"normal" normal
)
113 (const :tag
"regular" normal
)
114 (const :tag
"semibold" semi-bold
)
115 (const :tag
"semilight" semi-light
)
116 (const :tag
"ultralight" ultra-light
)
117 (const :tag
"ultrabold" ultra-bold
)))
121 :help-echo
"Font slant."
122 :value normal
; default
123 (const :tag
"italic" italic
)
124 (const :tag
"oblique" oblique
)
125 (const :tag
"normal" normal
)))
128 (choice :tag
"Underline"
129 :help-echo
"Control text underlining."
130 (const :tag
"Off" nil
)
132 (color :tag
"Colored")))
135 (choice :tag
"Overline"
136 :help-echo
"Control text overlining."
137 (const :tag
"Off" nil
)
139 (color :tag
"Colored")))
142 (choice :tag
"Strike-through"
143 :help-echo
"Control text strike-through."
144 (const :tag
"Off" nil
)
146 (color :tag
"Colored")))
149 ;; Fixme: this can probably be done better.
150 (choice :tag
"Box around text"
151 :help-echo
"Control box around text."
152 (const :tag
"Off" nil
)
154 :value
(:line-width
2 :color
"grey75" :style released-button
)
155 (const :format
"" :value
:line-width
)
156 (integer :tag
"Width")
157 (const :format
"" :value
:color
)
158 (choice :tag
"Color" (const :tag
"*" nil
) color
)
159 (const :format
"" :value
:style
)
161 (const :tag
"Raised" released-button
)
162 (const :tag
"Sunken" pressed-button
)
163 (const :tag
"None" nil
))))
164 ;; filter to make value suitable for customize
168 (or (and (consp real-value
)
169 (plist-get real-value
:line-width
))
170 (and (integerp real-value
) real-value
)
173 (or (and (consp real-value
) (plist-get real-value
:color
))
174 (and (stringp real-value
) real-value
)
177 (and (consp real-value
) (plist-get real-value
:style
))))
178 (list :line-width lwidth
:color color
:style style
))))
179 ;; filter to make customized-value suitable for storing
182 (let ((lwidth (plist-get cus-value
:line-width
))
183 (color (plist-get cus-value
:color
))
184 (style (plist-get cus-value
:style
)))
185 (cond ((and (null color
) (null style
))
187 ((and (null lwidth
) (null style
))
188 ;; actually can't happen, because LWIDTH is always an int
191 ;; Keep as a plist, but remove null entries
192 (nconc (and lwidth
`(:line-width
,lwidth
))
193 (and color
`(:color
,color
))
194 (and style
`(:style
,style
)))))))))
197 (choice :tag
"Inverse-video"
198 :help-echo
"Control whether text should be in inverse-video."
199 (const :tag
"Off" nil
)
200 (const :tag
"On" t
)))
203 (color :tag
"Foreground"
204 :help-echo
"Set foreground color (name or #RRGGBB hex spec)."))
207 (color :tag
"Background"
208 :help-echo
"Set background color (name or #RRGGBB hex spec)."))
211 (choice :tag
"Stipple"
212 :help-echo
"Background bit-mask"
213 (const :tag
"None" nil
)
215 :help-echo
"Name of bitmap file."
219 (repeat :tag
"Inherit"
220 :help-echo
"List of faces to inherit attributes from."
221 (face :Tag
"Face" default
))
222 ;; filter to make value suitable for customize
224 (cond ((or (null real-value
) (eq real-value
'unspecified
))
226 ((symbolp real-value
)
230 ;; filter to make customized-value suitable for storing
232 (if (and (consp cus-value
) (null (cdr cus-value
)))
236 "Alist of face attributes.
238 The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
239 where KEY is the name of the attribute, TYPE is a widget type for
240 editing the attribute, PRE-FILTER is a function to make the attribute's
241 value suitable for the customization widget, and POST-FILTER is a
242 function to make the customized value suitable for storing. PRE-FILTER
243 and POST-FILTER are optional.
245 The PRE-FILTER should take a single argument, the attribute value as
246 stored, and should return a value for customization (using the
247 customization type TYPE).
249 The POST-FILTER should also take a single argument, the value after
250 being customized, and should return a value suitable for setting the
251 given face attribute.")
253 (defun custom-face-attributes-get (face frame
)
254 "For FACE on FRAME, return an alternating list describing its attributes.
255 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
256 Each keyword should be listed in `custom-face-attributes'.
258 If FRAME is nil, use the global defaults for FACE."
259 (let ((attrs custom-face-attributes
)
262 (let* ((attribute (car (car attrs
)))
263 (value (face-attribute face attribute frame
)))
264 (setq attrs
(cdr attrs
))
265 (unless (or (eq value
'unspecified
)
266 (and (null value
) (memq attribute
'(:inherit
))))
267 (setq plist
(cons attribute
(cons value plist
))))))
273 (defun custom-set-faces (&rest args
)
274 "Initialize faces according to user preferences.
275 This associates the settings with the `user' theme.
276 The arguments should be a list where each entry has the form:
278 (FACE SPEC [NOW [COMMENT]])
280 SPEC is stored as the saved value for FACE, as well as the value for the
281 `user' theme. The `user' theme is one of the default themes known to Emacs.
282 See `custom-known-themes' for more information on the known themes.
283 See `custom-theme-set-faces' for more information on the interplay
284 between themes and faces.
285 See `defface' for the format of SPEC.
287 If NOW is present and non-nil, FACE is created now, according to SPEC.
288 COMMENT is a string comment about FACE."
289 (apply 'custom-theme-set-faces
'user args
))
291 (defun custom-theme-set-faces (theme &rest args
)
292 "Initialize faces for theme THEME.
293 The arguments should be a list where each entry has the form:
295 (FACE SPEC [NOW [COMMENT]])
297 SPEC is stored as the saved value for FACE, as well as the value for the
298 `user' theme. The `user' theme is one of the default themes known to Emacs.
299 See `custom-known-themes' for more information on the known themes.
300 See `custom-theme-set-faces' for more information on the interplay
301 between themes and faces.
302 See `defface' for the format of SPEC.
304 If NOW is present and non-nil, FACE is created now, according to SPEC.
305 COMMENT is a string comment about FACE.
307 Several properties of THEME and FACE are used in the process:
309 If THEME property `theme-immediate' is non-nil, this is equivalent of
310 providing the NOW argument to all faces in the argument list: FACE is
311 created now. The only difference is FACE property `force-face': if NOW
312 is non-nil, FACE property `force-face' is set to the symbol `rogue', else
313 if THEME property `theme-immediate' is non-nil, FACE property `force-face'
314 is set to the symbol `immediate'.
316 SPEC itself is saved in FACE property `saved-face' and it is stored in
317 FACE's list property `theme-face' \(using `custom-push-theme')."
318 (custom-check-theme theme
)
319 (let ((immediate (get theme
'theme-immediate
)))
321 (let ((entry (car args
)))
323 (let ((face (nth 0 entry
))
326 (comment (nth 3 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
)))
333 (setq oldspec
(get face
'theme-face
))
334 (when (not (and oldspec
(eq 'user
(caar oldspec
))))
335 (put face
'saved-face spec
)
336 (put face
'saved-face-comment comment
))
338 (custom-push-theme 'theme-face face theme
'set spec
)
339 (when (or now immediate
)
340 (put face
'force-face
(if now
'rogue
'immediate
)))
341 (when (or now immediate
(facep face
))
343 (make-empty-face face
))
344 (put face
'face-comment comment
)
345 (face-spec-set face spec
))
346 (setq args
(cdr args
)))
347 ;; Old format, a plist of FACE SPEC pairs.
348 (let ((face (nth 0 args
))
350 (if (get face
'face-alias
)
351 (setq face
(get face
'face-alias
)))
352 (put face
'saved-face spec
)
353 (custom-push-theme 'theme-face face theme
'set spec
))
354 (setq args
(cdr (cdr args
))))))))
356 ;; XEmacs compability function. In XEmacs, when you reset a Custom
357 ;; Theme, you have to specify the theme to reset it to. We just apply
360 (defun custom-theme-reset-faces (theme &rest args
)
361 "Reset the specs in THEME of some faces to their specs in other themes.
362 Each of the arguments ARGS has this form:
366 This means reset FACE. The argument IGNORED is ignored."
367 (custom-check-theme theme
)
369 (custom-push-theme 'theme-face
(car arg
) theme
'reset
)))
372 (defun custom-reset-faces (&rest args
)
373 "Reset the specs of some faces to their specs in specified themes.
374 This creates settings in the `user' theme.
376 Each of the arguments ARGS has this form:
380 This means reset FACE to its value in FROM-THEME."
381 (apply 'custom-theme-reset-faces
'user args
))
387 ;;; arch-tag: 9a5c4b63-0d27-4c92-a5af-f2c7ed764c2b
388 ;;; cus-face.el ends here