1 |
;;; cus-face.el --- customization support for faces |
;;; cus-face.el --- customization support for faces |
2 |
;; |
;; |
3 |
;; Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation, Inc. |
;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. |
4 |
;; |
;; |
5 |
;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
6 |
;; Keywords: help, faces |
;; Keywords: help, faces |
|
;; Version: Emacs |
|
7 |
|
|
8 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
9 |
|
|
36 |
(defun custom-declare-face (face spec doc &rest args) |
(defun custom-declare-face (face spec doc &rest args) |
37 |
"Like `defface', but FACE is evaluated as a normal argument." |
"Like `defface', but FACE is evaluated as a normal argument." |
38 |
(unless (get face 'face-defface-spec) |
(unless (get face 'face-defface-spec) |
|
(put face 'face-defface-spec spec) |
|
39 |
(when (fboundp 'facep) |
(when (fboundp 'facep) |
40 |
(unless (facep face) |
(unless (facep face) |
41 |
;; If the user has already created the face, respect that. |
;; If the user has already created the face, respect that. |
44 |
frame) |
frame) |
45 |
;; Create global face. |
;; Create global face. |
46 |
(make-empty-face face) |
(make-empty-face face) |
47 |
;; Create frame local faces |
;; Create frame-local faces |
48 |
(while frames |
(while frames |
49 |
(setq frame (car frames) |
(setq frame (car frames) |
50 |
frames (cdr frames)) |
frames (cdr frames)) |
52 |
;; When making a face after frames already exist |
;; When making a face after frames already exist |
53 |
(if (memq window-system '(x w32)) |
(if (memq window-system '(x w32)) |
54 |
(make-face-x-resource-internal face)))) |
(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 |
(when (and doc (null (face-documentation face))) |
(when (and doc (null (face-documentation face))) |
58 |
(set-face-documentation face (purecopy doc))) |
(set-face-documentation face (purecopy doc))) |
59 |
(custom-handle-all-keywords face args 'custom-face) |
(custom-handle-all-keywords face args 'custom-face) |
66 |
'((:family |
'((:family |
67 |
(string :tag "Font Family" |
(string :tag "Font Family" |
68 |
:help-echo "Font family or fontset alias name.")) |
:help-echo "Font family or fontset alias name.")) |
69 |
|
|
70 |
(:width |
(:width |
71 |
(choice :tag "Width" |
(choice :tag "Width" |
72 |
:help-echo "Font width." |
:help-echo "Font width." |
86 |
(const :tag "ultracondensed" ultra-condensed) |
(const :tag "ultracondensed" ultra-condensed) |
87 |
(const :tag "ultraexpanded" ultra-expanded) |
(const :tag "ultraexpanded" ultra-expanded) |
88 |
(const :tag "wide" extra-expanded))) |
(const :tag "wide" extra-expanded))) |
89 |
|
|
90 |
(:height |
(:height |
91 |
(choice :tag "Height" |
(choice :tag "Height" |
92 |
:help-echo "Face's font height." |
:help-echo "Face's font height." |
113 |
(const :tag "semilight" semi-light) |
(const :tag "semilight" semi-light) |
114 |
(const :tag "ultralight" ultra-light) |
(const :tag "ultralight" ultra-light) |
115 |
(const :tag "ultrabold" ultra-bold))) |
(const :tag "ultrabold" ultra-bold))) |
116 |
|
|
117 |
(:slant |
(:slant |
118 |
(choice :tag "Slant" |
(choice :tag "Slant" |
119 |
:help-echo "Font slant." |
:help-echo "Font slant." |
121 |
(const :tag "italic" italic) |
(const :tag "italic" italic) |
122 |
(const :tag "oblique" oblique) |
(const :tag "oblique" oblique) |
123 |
(const :tag "normal" normal))) |
(const :tag "normal" normal))) |
124 |
|
|
125 |
(:underline |
(:underline |
126 |
(choice :tag "Underline" |
(choice :tag "Underline" |
127 |
:help-echo "Control text underlining." |
:help-echo "Control text underlining." |
128 |
(const :tag "Off" nil) |
(const :tag "Off" nil) |
129 |
(const :tag "On" t) |
(const :tag "On" t) |
130 |
(color :tag "Colored"))) |
(color :tag "Colored"))) |
131 |
|
|
132 |
(:overline |
(:overline |
133 |
(choice :tag "Overline" |
(choice :tag "Overline" |
134 |
:help-echo "Control text overlining." |
:help-echo "Control text overlining." |
135 |
(const :tag "Off" nil) |
(const :tag "Off" nil) |
136 |
(const :tag "On" t) |
(const :tag "On" t) |
137 |
(color :tag "Colored"))) |
(color :tag "Colored"))) |
138 |
|
|
139 |
(:strike-through |
(:strike-through |
140 |
(choice :tag "Strike-through" |
(choice :tag "Strike-through" |
141 |
:help-echo "Control text strike-through." |
:help-echo "Control text strike-through." |
142 |
(const :tag "Off" nil) |
(const :tag "Off" nil) |
143 |
(const :tag "On" t) |
(const :tag "On" t) |
144 |
(color :tag "Colored"))) |
(color :tag "Colored"))) |
145 |
|
|
146 |
(:box |
(:box |
147 |
;; Fixme: this can probably be done better. |
;; Fixme: this can probably be done better. |
148 |
(choice :tag "Box around text" |
(choice :tag "Box around text" |
190 |
(nconc (and lwidth `(:line-width ,lwidth)) |
(nconc (and lwidth `(:line-width ,lwidth)) |
191 |
(and color `(:color ,color)) |
(and color `(:color ,color)) |
192 |
(and style `(:style ,style))))))))) |
(and style `(:style ,style))))))))) |
193 |
|
|
194 |
(:inverse-video |
(:inverse-video |
195 |
(choice :tag "Inverse-video" |
(choice :tag "Inverse-video" |
196 |
:help-echo "Control whether text should be in inverse-video." |
:help-echo "Control whether text should be in inverse-video." |
197 |
(const :tag "Off" nil) |
(const :tag "Off" nil) |
198 |
(const :tag "On" t))) |
(const :tag "On" t))) |
199 |
|
|
200 |
(:foreground |
(:foreground |
201 |
(color :tag "Foreground" |
(color :tag "Foreground" |
202 |
:help-echo "Set foreground color.")) |
:help-echo "Set foreground color.")) |
203 |
|
|
204 |
(:background |
(:background |
205 |
(color :tag "Background" |
(color :tag "Background" |
206 |
:help-echo "Set background color.")) |
:help-echo "Set background color.")) |
207 |
|
|
208 |
(:stipple |
(:stipple |
209 |
(choice :tag "Stipple" |
(choice :tag "Stipple" |
210 |
:help-echo "Background bit-mask" |
:help-echo "Background bit-mask" |
230 |
(if (and (consp cus-value) (null (cdr cus-value))) |
(if (and (consp cus-value) (null (cdr cus-value))) |
231 |
(car cus-value) |
(car cus-value) |
232 |
cus-value)))) |
cus-value)))) |
233 |
|
|
234 |
"Alist of face attributes. |
"Alist of face attributes. |
235 |
|
|
236 |
The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER), |
The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER), |
248 |
being customized, and should return a value suitable for setting the |
being customized, and should return a value suitable for setting the |
249 |
given face attribute.") |
given face attribute.") |
250 |
|
|
|
|
|
251 |
(defun custom-face-attributes-get (face frame) |
(defun custom-face-attributes-get (face frame) |
252 |
"For FACE on FRAME, return an alternating list describing its attributes. |
"For FACE on FRAME, return an alternating list describing its attributes. |
253 |
The list has the form (KEYWORD VALUE KEYWORD VALUE...). |
The list has the form (KEYWORD VALUE KEYWORD VALUE...). |
270 |
;;;###autoload |
;;;###autoload |
271 |
(defun custom-set-faces (&rest args) |
(defun custom-set-faces (&rest args) |
272 |
"Initialize faces according to user preferences. |
"Initialize faces according to user preferences. |
273 |
|
This associates the settings with the `user' theme. |
274 |
The arguments should be a list where each entry has the form: |
The arguments should be a list where each entry has the form: |
275 |
|
|
276 |
(FACE SPEC [NOW [COMMENT]]) |
(FACE SPEC [NOW [COMMENT]]) |
277 |
|
|
278 |
SPEC is stored as the saved value for FACE. |
SPEC is stored as the saved value for FACE, as well as the value for the |
279 |
|
`user' theme. The `user' theme is one of the default themes known to Emacs. |
280 |
|
See `custom-known-themes' for more information on the known themes. |
281 |
|
See `custom-theme-set-faces' for more information on the interplay |
282 |
|
between themes and faces. |
283 |
|
See `defface' for the format of SPEC. |
284 |
|
|
285 |
|
If NOW is present and non-nil, FACE is created now, according to SPEC. |
286 |
|
COMMENT is a string comment about FACE." |
287 |
|
(apply 'custom-theme-set-faces 'user args)) |
288 |
|
|
289 |
|
(defun custom-theme-set-faces (theme &rest args) |
290 |
|
"Initialize faces for theme THEME. |
291 |
|
The arguments should be a list where each entry has the form: |
292 |
|
|
293 |
|
(FACE SPEC [NOW [COMMENT]]) |
294 |
|
|
295 |
|
SPEC is stored as the saved value for FACE, as well as the value for the |
296 |
|
`user' theme. The `user' theme is one of the default themes known to Emacs. |
297 |
|
See `custom-known-themes' for more information on the known themes. |
298 |
|
See `custom-theme-set-faces' for more information on the interplay |
299 |
|
between themes and faces. |
300 |
|
See `defface' for the format of SPEC. |
301 |
|
|
302 |
If NOW is present and non-nil, FACE is created now, according to SPEC. |
If NOW is present and non-nil, FACE is created now, according to SPEC. |
303 |
COMMENT is a string comment about FACE. |
COMMENT is a string comment about FACE. |
304 |
|
|
305 |
See `defface' for the format of SPEC." |
Several properties of THEME and FACE are used in the process: |
306 |
(while args |
|
307 |
(let ((entry (car args))) |
If THEME property `theme-immediate' is non-nil, this is equivalent of |
308 |
(if (listp entry) |
providing the NOW argument to all faces in the argument list: FACE is |
309 |
(let ((face (nth 0 entry)) |
created now. The only difference is FACE property `force-face': if NOW |
310 |
(spec (nth 1 entry)) |
is non-nil, FACE property `force-face' is set to the symbol `rogue', else |
311 |
(now (nth 2 entry)) |
if THEME property `theme-immediate' is non-nil, FACE property `force-face' |
312 |
(comment (nth 3 entry))) |
is set to the symbol `immediate'. |
313 |
(put face 'saved-face spec) |
|
314 |
(put face 'saved-face-comment comment) |
SPEC itself is saved in FACE property `saved-face' and it is stored in |
315 |
(when now |
FACE's list property `theme-face' \(using `custom-push-theme')." |
316 |
(put face 'force-face t)) |
(custom-check-theme theme) |
317 |
(when (or now (facep face)) |
(let ((immediate (get theme 'theme-immediate))) |
318 |
(put face 'face-comment comment) |
(while args |
319 |
(make-empty-face face) |
(let ((entry (car args))) |
320 |
(face-spec-set face spec)) |
(if (listp entry) |
321 |
|
(let ((face (nth 0 entry)) |
322 |
|
(spec (nth 1 entry)) |
323 |
|
(now (nth 2 entry)) |
324 |
|
(comment (nth 3 entry))) |
325 |
|
(put face 'saved-face spec) |
326 |
|
(put face 'saved-face-comment comment) |
327 |
|
(custom-push-theme 'theme-face face theme 'set spec) |
328 |
|
(when (or now immediate) |
329 |
|
(put face 'force-face (if now 'rogue 'immediate))) |
330 |
|
(when (or now immediate (facep face)) |
331 |
|
(unless (facep face) |
332 |
|
(make-empty-face face)) |
333 |
|
(put face 'face-comment comment) |
334 |
|
(face-spec-set face spec)) |
335 |
(setq args (cdr args))) |
(setq args (cdr args))) |
336 |
;; Old format, a plist of FACE SPEC pairs. |
;; Old format, a plist of FACE SPEC pairs. |
337 |
(let ((face (nth 0 args)) |
(let ((face (nth 0 args)) |
338 |
(spec (nth 1 args))) |
(spec (nth 1 args))) |
339 |
(put face 'saved-face spec)) |
(put face 'saved-face spec) |
340 |
(setq args (cdr (cdr args))))))) |
(custom-push-theme 'theme-face face theme 'set spec)) |
341 |
|
(setq args (cdr (cdr args)))))))) |
342 |
|
|
343 |
|
;;;###autoload |
344 |
|
(defun custom-theme-face-value (face theme) |
345 |
|
"Return spec of FACE in THEME if THEME modifies FACE. |
346 |
|
Value is nil otherwise. The association between theme and spec for FACE |
347 |
|
is stored in FACE's property `theme-face'. The appropriate face |
348 |
|
is retrieved using `custom-theme-value'." |
349 |
|
;; Returns car because the value is stored inside a one element list |
350 |
|
(car-safe (custom-theme-value theme (get face 'theme-face)))) |
351 |
|
|
352 |
|
(defun custom-theme-reset-internal-face (face to-theme) |
353 |
|
"Reset FACE to the value defined by TO-THEME. |
354 |
|
If FACE is not defined in TO-THEME, reset FACE to the standard |
355 |
|
value. See `custom-theme-face-value'. The standard value is |
356 |
|
stored in SYMBOL's property `face-defface-spec' by `defface'." |
357 |
|
(let ((spec (custom-theme-face-value face to-theme)) |
358 |
|
was-in-theme) |
359 |
|
(setq was-in-theme spec) |
360 |
|
(setq spec (or spec (get face 'face-defface-spec))) |
361 |
|
(when spec |
362 |
|
(put face 'save-face was-in-theme) |
363 |
|
(when (or (get face 'force-face) (facep face)) |
364 |
|
(unless (facep face) |
365 |
|
(make-empty-face face)) |
366 |
|
(face-spec-set face spec))) |
367 |
|
spec)) |
368 |
|
|
369 |
|
;;;###autoload |
370 |
|
(defun custom-theme-reset-faces (theme &rest args) |
371 |
|
"Reset the value of the face to values previously defined. |
372 |
|
Associate this setting with THEME. |
373 |
|
|
374 |
|
ARGS is a list of lists of the form |
375 |
|
|
376 |
|
(FACE TO-THEME) |
377 |
|
|
378 |
|
This means reset FACE to its value in TO-THEME." |
379 |
|
(custom-check-theme theme) |
380 |
|
(mapcar '(lambda (arg) |
381 |
|
(apply 'custom-theme-reset-internal-face arg) |
382 |
|
(custom-push-theme 'theme-face (car arg) theme 'reset (cadr arg))) |
383 |
|
args)) |
384 |
|
|
385 |
|
;;;###autoload |
386 |
|
(defun custom-reset-faces (&rest args) |
387 |
|
"Reset the value of the face to values previously saved. |
388 |
|
This is the setting assosiated the `user' theme. |
389 |
|
|
390 |
|
ARGS is defined as for `custom-theme-reset-faces'" |
391 |
|
(apply 'custom-theme-reset-faces 'user args)) |
392 |
|
|
393 |
;;; The End. |
;;; The End. |
394 |
|
|