1 ;;; faces.el --- Lisp interface to the C "face" structure
3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Board of Trustees, University of Illinois
5 ;; Copyright (C) 1995, 1996 Ben Wing
7 ;; Author: Ben Wing <ben@xemacs.org>
8 ;; Keywords: faces, internal, dumped
10 ;; This file is part of XEmacs.
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
27 ;;; Synched up with: Not synched with FSF. Almost completely divergent.
31 ;; This file is dumped with XEmacs.
33 ;; face implementation #1 (used Lisp vectors and parallel C vectors;
34 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@jwz.org>
35 ;; pre Lucid-Emacs 19.0.
37 ;; face implementation #2 (used one face object per frame per face)
38 ;; authored by Jamie Zawinski for 19.9.
40 ;; face implementation #3 (use one face object per face) originally
41 ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>,
42 ;; rewritten by Ben Wing with the advent of specifiers.
45 ;;; Some stuff in FSF's faces.el is in our x-faces.el.
50 "Support for multiple text attributes (fonts, colors, ...)
51 Such a collection of attributes is called a \"face\"."
55 (defun read-face-name (prompt)
57 (while (= (length face) 0) ; nil or ""
58 (setq face (completing-read prompt
59 (mapcar (lambda (x) (list (symbol-name x)))
64 (defun face-interactive (what &optional bool)
65 (let* ((fn (intern (concat "face-" what "-instance")))
66 (face (read-face-name (format "Set %s of face: " what)))
67 (default (if (fboundp fn)
68 ;; #### we should distinguish here between
69 ;; explicitly setting the value to be the
70 ;; same as the default face's value, and
71 ;; not setting a value at all.
74 (y-or-n-p (format "Should face %s be %s? "
75 (symbol-name face) bool))
76 (read-string (format "Set %s of face %s to: "
77 what (symbol-name face))
78 (cond ((font-instance-p default)
79 (font-instance-name default))
80 ((color-instance-p default)
81 (color-instance-name default))
82 ((image-instance-p default)
83 (image-instance-file-name default))
85 (list face (if (equal value "") nil value))))
87 (defconst built-in-face-specifiers
88 (built-in-face-specifiers)
89 "A list of the built-in face properties that are specifiers.")
91 (defun face-property (face property &optional locale tag-set exact-p)
92 "Return FACE's value of the given PROPERTY.
94 If LOCALE is omitted, the FACE's actual value for PROPERTY will be
95 returned. For built-in properties, this will be a specifier object
96 of a type appropriate to the property (e.g. a font or color
97 specifier). For other properties, this could be anything.
99 If LOCALE is supplied, then instead of returning the actual value,
100 the specification(s) for the given locale or locale type will
101 be returned. This will only work if the actual value of
102 PROPERTY is a specifier (this will always be the case for built-in
103 properties, but not or not may apply to user-defined properties).
104 If the actual value of PROPERTY is not a specifier, this value
105 will simply be returned regardless of LOCALE.
107 The return value will be a list of instantiators (e.g. strings
108 specifying a font or color name), or a list of specifications, each
109 of which is a cons of a locale and a list of instantiators.
110 Specifically, if LOCALE is a particular locale (a buffer, window,
111 frame, device, or 'global), a list of instantiators for that locale
112 will be returned. Otherwise, if LOCALE is a locale type (one of
113 the symbols 'buffer, 'window, 'frame, or 'device), the specifications
114 for all locales of that type will be returned. Finally, if LOCALE is
115 'all, the specifications for all locales of all types will be returned.
117 The specifications in a specifier determine what the value of
118 PROPERTY will be in a particular \"domain\" or set of circumstances,
119 which is typically a particular Emacs window along with the buffer
120 it contains and the frame and device it lies within. The value
121 is derived from the instantiator associated with the most specific
122 locale (in the order buffer, window, frame, device, and 'global)
123 that matches the domain in question. In other words, given a domain
124 (i.e. an Emacs window, usually), the specifier for PROPERTY will first
125 be searched for a specification whose locale is the buffer contained
126 within that window; then for a specification whose locale is the window
127 itself; then for a specification whose locale is the frame that the
128 window is contained within; etc. The first instantiator that is
129 valid for the domain (usually this means that the instantiator is
130 recognized by the device [i.e. the X server or TTY device] that the
131 domain is on. The function `face-property-instance' actually does
132 all this, and is used to determine how to display the face.
134 See `set-face-property' for the built-in property-names."
136 (setq face (get-face face))
137 (let ((value (get face property)))
139 (or (memq property built-in-face-specifiers)
141 (setq value (specifier-specs value locale tag-set exact-p)))
144 (defun convert-face-property-into-specifier (face property)
145 "Convert PROPERTY on FACE into a specifier, if it's not already."
146 (setq face (get-face face))
147 (let ((specifier (get face property)))
148 ;; if a user-property does not have a specifier but a
149 ;; locale was specified, put a specifier there.
150 ;; If there was already a value there, convert it to a
151 ;; specifier with the value as its 'global instantiator.
152 (unless (specifierp specifier)
153 (let ((new-specifier (make-specifier 'generic)))
154 (if (or (not (null specifier))
155 ;; make sure the nil returned from `get' wasn't
156 ;; actually the value of the property
157 (null (get face property t)))
158 (add-spec-to-specifier new-specifier specifier))
159 (setq specifier new-specifier)
160 (put face property specifier)))))
162 (defun face-property-instance (face property
163 &optional domain default no-fallback)
164 "Return the instance of FACE's PROPERTY in the specified DOMAIN.
166 Under most circumstances, DOMAIN will be a particular window,
167 and the returned instance describes how the specified property
168 actually is displayed for that window and the particular buffer
169 in it. Note that this may not be the same as how the property
170 appears when the buffer is displayed in a different window or
171 frame, or how the property appears in the same window if you
172 switch to another buffer in that window; and in those cases,
173 the returned instance would be different.
175 The returned instance will typically be a color-instance,
176 font-instance, or pixmap-instance object, and you can query
177 it using the appropriate object-specific functions. For example,
178 you could use `color-instance-rgb-components' to find out the
179 RGB (red, green, and blue) components of how the 'background
180 property of the 'highlight face is displayed in a particular
181 window. The results might be different from the results
182 you would get for another window (perhaps the user
183 specified a different color for the frame that window is on;
184 or perhaps the same color was specified but the window is
185 on a different X server, and that X server has different RGB
186 values for the color from this one).
188 DOMAIN defaults to the selected window if omitted.
190 DOMAIN can be a frame or device, instead of a window. The value
191 returned for a such a domain is used in special circumstances
192 when a more specific domain does not apply; for example, a frame
193 value might be used for coloring a toolbar, which is conceptually
194 attached to a frame rather than a particular window. The value
195 is also useful in determining what the value would be for a
196 particular window within the frame or device, if it is not
197 overridden by a more specific specification.
199 If PROPERTY does not name a built-in property, its value will
200 simply be returned unless it is a specifier object, in which case
201 it will be instanced using `specifier-instance'.
203 Optional arguments DEFAULT and NO-FALLBACK are the same as in
204 `specifier-instance'."
206 (setq face (get-face face))
207 (let ((value (get face property)))
208 (if (specifierp value)
209 (setq value (specifier-instance value domain default no-fallback)))
212 (defun face-property-matching-instance (face property matchspec
213 &optional domain default
215 "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN.
216 Currently the only useful value for MATCHSPEC is a charset, when used
217 in conjunction with the face's font; this allows you to retrieve a
218 font that can be used to display a particular charset, rather than just
221 Other than MATCHSPEC, this function is identical to `face-property-instance'.
222 See also `specifier-matching-instance' for a fuller description of the
225 (setq face (get-face face))
226 (let ((value (get face property)))
227 (if (specifierp value)
228 (setq value (specifier-matching-instance value matchspec domain
229 default no-fallback)))
232 (defun set-face-property (face property value &optional locale tag-set
234 "Change a property of FACE.
236 NOTE: If you want to remove a property from a face, use `remove-face-property'
237 rather than attempting to set a value of nil for the property.
239 For built-in properties, the actual value of the property is a
240 specifier and you cannot change this; but you can change the
241 specifications within the specifier, and that is what this function
242 will do. For user-defined properties, you can use this function
243 to either change the actual value of the property or, if this value
244 is a specifier, change the specifications within it.
246 If PROPERTY is a built-in property, the specifications to be added to
247 this property can be supplied in many different ways:
249 -- If VALUE is a simple instantiator (e.g. a string naming a font or
250 color) or a list of instantiators, then the instantiator(s) will
251 be added as a specification of the property for the given LOCALE
252 (which defaults to 'global if omitted).
253 -- If VALUE is a list of specifications (each of which is a cons of
254 a locale and a list of instantiators), then LOCALE must be nil
255 (it does not make sense to explicitly specify a locale in this
256 case), and specifications will be added as given.
257 -- If VALUE is a specifier (as would be returned by `face-property'
258 if no LOCALE argument is given), then some or all of the
259 specifications in the specifier will be added to the property.
260 In this case, the function is really equivalent to
261 `copy-specifier' and LOCALE has the same semantics (if it is
262 a particular locale, the specification for the locale will be
263 copied; if a locale type, specifications for all locales of
264 that type will be copied; if nil or 'all, then all
265 specifications will be copied).
267 HOW-TO-ADD should be either nil or one of the symbols 'prepend,
268 'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale,
269 'remove-locale-type, or 'remove-all. See `copy-specifier' and
270 `add-spec-to-specifier' for a description of what each of
271 these means. Most of the time, you do not need to worry about
272 this argument; the default behavior usually is fine.
274 In general, it is OK to pass an instance object (e.g. as returned
275 by `face-property-instance') as an instantiator in place of
276 an actual instantiator. In such a case, the instantiator used
277 to create that instance object will be used (for example, if
278 you set a font-instance object as the value of the 'font
279 property, then the font name used to create that object will
280 be used instead). If some cases, however, doing this
281 conversion does not make sense, and this will be noted in
282 the documentation for particular types of instance objects.
284 If PROPERTY is not a built-in property, then this function will
285 simply set its value if LOCALE is nil. However, if LOCALE is
286 given, then this function will attempt to add VALUE as the
287 instantiator for the given LOCALE, using `add-spec-to-specifier'.
288 If the value of the property is not a specifier, it will
289 automatically be converted into a 'generic specifier.
292 The following symbols have predefined meanings:
294 foreground The foreground color of the face.
295 For valid instantiators, see `color-specifier-p'.
297 background The background color of the face.
298 For valid instantiators, see `color-specifier-p'.
300 font The font used to display text covered by this face.
301 For valid instantiators, see `font-specifier-p'.
303 display-table The display table of the face.
304 This should be a vector of 256 elements.
306 background-pixmap The pixmap displayed in the background of the face.
307 Only used by faces on X devices.
308 For valid instantiators, see `image-specifier-p'.
310 underline Underline all text covered by this face.
311 For valid instantiators, see `face-boolean-specifier-p'.
313 strikethru Draw a line through all text covered by this face.
314 For valid instantiators, see `face-boolean-specifier-p'.
316 highlight Highlight all text covered by this face.
317 Only used by faces on TTY devices.
318 For valid instantiators, see `face-boolean-specifier-p'.
320 dim Dim all text covered by this face.
321 For valid instantiators, see `face-boolean-specifier-p'.
323 blinking Blink all text covered by this face.
324 Only used by faces on TTY devices.
325 For valid instantiators, see `face-boolean-specifier-p'.
327 reverse Reverse the foreground and background colors.
328 Only used by faces on TTY devices.
329 For valid instantiators, see `face-boolean-specifier-p'.
331 doc-string Description of what the face's normal use is.
332 NOTE: This is not a specifier, unlike all
333 the other built-in properties, and cannot
334 contain locale-specific values."
336 (setq face (get-face face))
337 (if (memq property built-in-face-specifiers)
338 (set-specifier (get face property) value locale tag-set how-to-add)
340 ;; This section adds user defined properties.
342 (put face property value)
343 (convert-face-property-into-specifier face property)
344 (add-spec-to-specifier (get face property) value locale tag-set
348 (defun remove-face-property (face property &optional locale tag-set exact-p)
349 "Remove a property from FACE.
350 For built-in properties, this is analogous to `remove-specifier'.
351 See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P
353 (or locale (setq locale 'all))
354 (if (memq property built-in-face-specifiers)
355 (remove-specifier (face-property face property) locale tag-set exact-p)
357 (remprop (get-face face) property)
358 (convert-face-property-into-specifier face property)
359 (remove-specifier (face-property face property) locale tag-set
362 (defun reset-face (face &optional locale tag-set exact-p)
363 "Clear all existing built-in specifications from FACE.
364 This makes FACE inherit all its display properties from 'default.
365 WARNING: Be absolutely sure you want to do this!!! It is a dangerous
366 operation and is not undoable.
368 The arguments LOCALE, TAG-SET and EXACT-P are the same as for
371 (remove-specifier (face-property face x) locale tag-set exact-p))
372 built-in-face-specifiers)
375 (defun set-face-parent (face parent &optional locale tag-set how-to-add)
376 "Set the parent of FACE to PARENT, for all properties.
377 This makes all properties of FACE inherit from PARENT."
378 (setq parent (get-face parent))
380 (set-face-property face x (vector parent) locale tag-set
383 (delq 'background-pixmap
384 (copy-sequence built-in-face-specifiers))))
385 (set-face-background-pixmap face (vector 'inherit ':face parent)
386 locale tag-set how-to-add)
389 (defun face-doc-string (face)
390 "Return the documentation string for FACE."
391 (face-property face 'doc-string))
393 (defun set-face-doc-string (face doc-string)
394 "Change the documentation string of FACE to DOC-STRING."
395 (interactive (face-interactive "doc-string"))
396 (set-face-property face 'doc-string doc-string))
398 (defun face-font-name (face &optional domain charset)
399 "Return the font name of FACE in DOMAIN, or nil if it is unspecified.
400 DOMAIN is as in `face-font-instance'."
401 (let ((f (face-font-instance face domain charset)))
402 (and f (font-instance-name f))))
404 (defun face-font (face &optional locale tag-set exact-p)
405 "Return the font of FACE in LOCALE, or nil if it is unspecified.
407 FACE may be either a face object or a symbol representing a face.
409 LOCALE may be a locale (the instantiators for that particular locale
410 will be returned), a locale type (the specifications for all locales
411 of that type will be returned), 'all (all specifications will be
412 returned), or nil (the actual specifier object will be returned).
414 See `face-property' for more information."
415 (face-property face 'font locale tag-set exact-p))
417 (defun face-font-instance (face &optional domain charset)
418 "Return the instance of FACE's font in DOMAIN.
420 FACE may be either a face object or a symbol representing a face.
422 Normally DOMAIN will be a window or nil (meaning the selected window),
423 and an instance object describing how the font appears in that
424 particular window and buffer will be returned.
426 See `face-property-instance' for more information."
428 (face-property-matching-instance face 'font charset domain)
429 (face-property-instance face 'font domain)))
431 (defun set-face-font (face font &optional locale tag-set how-to-add)
432 "Change the font of FACE to FONT in LOCALE.
434 FACE may be either a face object or a symbol representing a face.
436 FONT should be an instantiator (see `font-specifier-p'), a list of
437 instantiators, an alist of specifications (each mapping a
438 locale to an instantiator list), or a font specifier object.
440 If FONT is an alist, LOCALE must be omitted. If FONT is a
441 specifier object, LOCALE can be a locale, a locale type, 'all,
442 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE
443 specifies the locale under which the specified instantiator(s)
444 will be added, and defaults to 'global.
446 See `set-face-property' for more information."
447 (interactive (face-interactive "font"))
448 (set-face-property face 'font font locale tag-set how-to-add))
450 (defun face-foreground (face &optional locale tag-set exact-p)
451 "Return the foreground of FACE in LOCALE, or nil if it is unspecified.
453 FACE may be either a face object or a symbol representing a face.
455 LOCALE may be a locale (the instantiators for that particular locale
456 will be returned), a locale type (the specifications for all locales
457 of that type will be returned), 'all (all specifications will be
458 returned), or nil (the actual specifier object will be returned).
460 See `face-property' for more information."
461 (face-property face 'foreground locale tag-set exact-p))
463 (defun face-foreground-instance (face &optional domain default no-fallback)
464 "Return the instance of FACE's foreground in DOMAIN.
466 FACE may be either a face object or a symbol representing a face.
468 Normally DOMAIN will be a window or nil (meaning the selected window),
469 and an instance object describing how the foreground appears in that
470 particular window and buffer will be returned.
472 See `face-property-instance' for more information."
473 (face-property-instance face 'foreground domain default no-fallback))
475 (defun face-foreground-name (face &optional domain default no-fallback)
476 "Return the name of FACE's foreground color in DOMAIN.
478 FACE may be either a face object or a symbol representing a face.
480 Normally DOMAIN will be a window or nil (meaning the selected window),
481 and an instance object describing how the background appears in that
482 particular window and buffer will be returned.
484 See `face-property-instance' for more information."
485 (color-instance-name (face-foreground-instance
486 face domain default no-fallback)))
488 (defun set-face-foreground (face color &optional locale tag-set how-to-add)
489 "Change the foreground color of FACE to COLOR in LOCALE.
491 FACE may be either a face object or a symbol representing a face.
493 COLOR should be an instantiator (see `color-specifier-p'), a list of
494 instantiators, an alist of specifications (each mapping a locale to
495 an instantiator list), or a color specifier object.
497 If COLOR is an alist, LOCALE must be omitted. If COLOR is a
498 specifier object, LOCALE can be a locale, a locale type, 'all,
499 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE
500 specifies the locale under which the specified instantiator(s)
501 will be added, and defaults to 'global.
503 See `set-face-property' for more information."
504 (interactive (face-interactive "foreground"))
505 (set-face-property face 'foreground color locale tag-set how-to-add))
507 (defun face-background (face &optional locale tag-set exact-p)
508 "Return the background color of FACE in LOCALE, or nil if it is unspecified.
510 FACE may be either a face object or a symbol representing a face.
512 LOCALE may be a locale (the instantiators for that particular locale
513 will be returned), a locale type (the specifications for all locales
514 of that type will be returned), 'all (all specifications will be
515 returned), or nil (the actual specifier object will be returned).
517 See `face-property' for more information."
518 (face-property face 'background locale tag-set exact-p))
520 (defun face-background-instance (face &optional domain default no-fallback)
521 "Return the instance of FACE's background in DOMAIN.
523 FACE may be either a face object or a symbol representing a face.
525 Normally DOMAIN will be a window or nil (meaning the selected window),
526 and an instance object describing how the background appears in that
527 particular window and buffer will be returned.
529 See `face-property-instance' for more information."
530 (face-property-instance face 'background domain default no-fallback))
532 (defun face-background-name (face &optional domain default no-fallback)
533 "Return the name of FACE's background color in DOMAIN.
535 FACE may be either a face object or a symbol representing a face.
537 Normally DOMAIN will be a window or nil (meaning the selected window),
538 and an instance object describing how the background appears in that
539 particular window and buffer will be returned.
541 See `face-property-instance' for more information."
542 (color-instance-name (face-background-instance
543 face domain default no-fallback)))
545 (defun set-face-background (face color &optional locale tag-set how-to-add)
546 "Change the background color of FACE to COLOR in LOCALE.
548 FACE may be either a face object or a symbol representing a face.
550 COLOR should be an instantiator (see `color-specifier-p'), a list of
551 instantiators, an alist of specifications (each mapping a locale to
552 an instantiator list), or a color specifier object.
554 If COLOR is an alist, LOCALE must be omitted. If COLOR is a
555 specifier object, LOCALE can be a locale, a locale type, 'all,
556 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE
557 specifies the locale under which the specified instantiator(s)
558 will be added, and defaults to 'global.
560 See `set-face-property' for more information."
561 (interactive (face-interactive "background"))
562 (set-face-property face 'background color locale tag-set how-to-add))
564 (defun face-background-pixmap (face &optional locale tag-set exact-p)
565 "Return the background pixmap of FACE in LOCALE, or nil if it is unspecified.
566 This property is only used on window system devices.
568 FACE may be either a face object or a symbol representing a face.
570 LOCALE may be a locale (the instantiators for that particular locale
571 will be returned), a locale type (the specifications for all locales
572 of that type will be returned), 'all (all specifications will be
573 returned), or nil (the actual specifier object will be returned).
575 See `face-property' for more information."
576 (face-property face 'background-pixmap locale tag-set exact-p))
578 (defun face-background-pixmap-instance (face &optional domain default
580 "Return the instance of FACE's background pixmap in DOMAIN.
582 FACE may be either a face object or a symbol representing a face.
584 Normally DOMAIN will be a window or nil (meaning the selected window),
585 and an instance object describing how the background appears in that
586 particular window and buffer will be returned.
588 See `face-property-instance' for more information."
589 (face-property-instance face 'background-pixmap domain default no-fallback))
591 (defun set-face-background-pixmap (face pixmap &optional locale tag-set
593 "Change the background pixmap of FACE to PIXMAP in LOCALE.
594 This property is only used on window system devices.
596 FACE may be either a face object or a symbol representing a face.
598 PIXMAP should be an instantiator (see `image-specifier-p'), a list
599 of instantiators, an alist of specifications (each mapping a locale
600 to an instantiator list), or an image specifier object.
602 If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a
603 specifier object, LOCALE can be a locale, a locale type, 'all,
604 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE
605 specifies the locale under which the specified instantiator(s)
606 will be added, and defaults to 'global.
608 See `set-face-property' for more information."
609 (interactive (face-interactive "background-pixmap"))
610 (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add))
612 (defun face-display-table (face &optional locale tag-set exact-p)
613 "Return the display table of FACE in LOCALE.
615 A vector (as returned by `make-display-table') will be returned.
617 LOCALE may be a locale (the instantiators for that particular locale
618 will be returned), a locale type (the specifications for all locales
619 of that type will be returned), 'all (all specifications will be
620 returned), or nil (the actual specifier object will be returned).
622 See `face-property' for more information."
623 (face-property face 'display-table locale tag-set exact-p))
625 (defun face-display-table-instance (face &optional domain default no-fallback)
626 "Return the instance of FACE's display table in DOMAIN.
627 A vector (as returned by `make-display-table') will be returned.
629 See `face-property-instance' for the semantics of the DOMAIN argument."
630 (face-property-instance face 'display-table domain default no-fallback))
632 (defun set-face-display-table (face display-table &optional locale tag-set
634 "Change the display table of FACE to DISPLAY-TABLE in LOCALE.
635 DISPLAY-TABLE should be a vector as returned by `make-display-table'.
637 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
638 HOW-TO-ADD arguments."
639 (interactive (face-interactive "display-table"))
640 (set-face-property face 'display-table display-table locale tag-set
643 ;; The following accessors and mutators are, IMHO, good
644 ;; implementation. Cf. with `make-face-bold'.
646 (defun face-underline-p (face &optional domain default no-fallback)
647 "Return t if FACE is underlined in DOMAIN.
648 See `face-property-instance' for the semantics of the DOMAIN argument."
649 (face-property-instance face 'underline domain default no-fallback))
651 (defun set-face-underline-p (face underline-p &optional locale tag-set
653 "Change the underline property of FACE to UNDERLINE-P.
654 UNDERLINE-P is normally a face-boolean instantiator; see
655 `face-boolean-specifier-p'.
656 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
657 HOW-TO-ADD arguments."
658 (interactive (face-interactive "underline-p" "underlined"))
659 (set-face-property face 'underline underline-p locale tag-set how-to-add))
661 (defun face-strikethru-p (face &optional domain default no-fallback)
662 "Return t if FACE is strikethru-d (i.e. struck through) in DOMAIN.
663 See `face-property-instance' for the semantics of the DOMAIN argument."
664 (face-property-instance face 'strikethru domain default no-fallback))
666 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set
668 "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE.
669 STRIKETHRU-P is normally a face-boolean instantiator; see
670 `face-boolean-specifier-p'.
671 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
672 HOW-TO-ADD arguments."
673 (interactive (face-interactive "strikethru-p" "strikethru-d"))
674 (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add))
676 (defun face-highlight-p (face &optional domain default no-fallback)
677 "Return t if FACE is highlighted in DOMAIN (TTY domains only).
678 See `face-property-instance' for the semantics of the DOMAIN argument."
679 (face-property-instance face 'highlight domain default no-fallback))
681 (defun set-face-highlight-p (face highlight-p &optional locale tag-set
683 "Change whether FACE is highlighted in LOCALE (TTY locales only).
684 HIGHLIGHT-P is normally a face-boolean instantiator; see
685 `face-boolean-specifier-p'.
686 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
687 HOW-TO-ADD arguments."
688 (interactive (face-interactive "highlight-p" "highlighted"))
689 (set-face-property face 'highlight highlight-p locale tag-set how-to-add))
691 (defun face-dim-p (face &optional domain default no-fallback)
692 "Return t if FACE is dimmed in DOMAIN.
693 See `face-property-instance' for the semantics of the DOMAIN argument."
694 (face-property-instance face 'dim domain default no-fallback))
696 (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add)
697 "Change whether FACE is dimmed in LOCALE.
698 DIM-P is normally a face-boolean instantiator; see
699 `face-boolean-specifier-p'.
700 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
701 HOW-TO-ADD arguments."
702 (interactive (face-interactive "dim-p" "dimmed"))
703 (set-face-property face 'dim dim-p locale tag-set how-to-add))
705 (defun face-blinking-p (face &optional domain default no-fallback)
706 "Return t if FACE is blinking in DOMAIN (TTY domains only).
707 See `face-property-instance' for the semantics of the DOMAIN argument."
708 (face-property-instance face 'blinking domain default no-fallback))
710 (defun set-face-blinking-p (face blinking-p &optional locale tag-set
712 "Change whether FACE is blinking in LOCALE (TTY locales only).
713 BLINKING-P is normally a face-boolean instantiator; see
714 `face-boolean-specifier-p'.
715 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
716 HOW-TO-ADD arguments."
717 (interactive (face-interactive "blinking-p" "blinking"))
718 (set-face-property face 'blinking blinking-p locale tag-set how-to-add))
720 (defun face-reverse-p (face &optional domain default no-fallback)
721 "Return t if FACE is reversed in DOMAIN (TTY domains only).
722 See `face-property-instance' for the semantics of the DOMAIN argument."
723 (face-property-instance face 'reverse domain default no-fallback))
725 (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add)
726 "Change whether FACE is reversed in LOCALE (TTY locales only).
727 REVERSE-P is normally a face-boolean instantiator; see
728 `face-boolean-specifier-p'.
729 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
730 HOW-TO-ADD arguments."
731 (interactive (face-interactive "reverse-p" "reversed"))
732 (set-face-property face 'reverse reverse-p locale tag-set how-to-add))
735 (defun face-property-equal (face1 face2 prop domain)
736 (equal (face-property-instance face1 prop domain)
737 (face-property-instance face2 prop domain)))
739 (defun face-equal-loop (props face1 face2 domain)
741 (face-property-equal face1 face2 (car props) domain))
742 (setq props (cdr props)))
745 (defun face-equal (face1 face2 &optional domain)
746 "Return t if FACE1 and FACE2 will display in the same way in DOMAIN.
747 See `face-property-instance' for the semantics of the DOMAIN argument."
748 (if (null domain) (setq domain (selected-window)))
749 (if (not (valid-specifier-domain-p domain))
750 (error "Invalid specifier domain"))
751 (let ((device (dfw-device domain))
752 (common-props '(foreground background font display-table underline
754 (win-props '(background-pixmap strikethru))
755 (tty-props '(highlight blinking reverse)))
757 ;; First check the properties which are used in common between the
758 ;; x and tty devices. Then, check those properties specific to
759 ;; the particular device type.
760 (and (face-equal-loop common-props face1 face2 domain)
761 (cond ((eq 'tty (device-type device))
762 (face-equal-loop tty-props face1 face2 domain))
763 ((or (eq 'x (device-type device))
764 (eq 'mswindows (device-type device)))
765 (face-equal-loop win-props face1 face2 domain))
768 (defun face-differs-from-default-p (face &optional domain)
769 "Return t if FACE will display differently from the default face in DOMAIN.
770 See `face-property-instance' for the semantics of the DOMAIN argument."
771 (not (face-equal face 'default domain)))
773 ; moved from x-faces.el
774 (defun try-font-name (name &optional device)
775 ;; yes, name really should be here twice.
776 (and name (make-font-instance name device t) name))
779 ;; This function is a terrible, disgusting hack!!!! Need to
780 ;; separate out the font elements as separate face properties!
782 ;; WE DEMAND LEXICAL SCOPING!!!
783 ;; WE DEMAND LEXICAL SCOPING!!!
784 ;; WE DEMAND LEXICAL SCOPING!!!
785 ;; WE DEMAND LEXICAL SCOPING!!!
786 ;; WE DEMAND LEXICAL SCOPING!!!
787 ;; WE DEMAND LEXICAL SCOPING!!!
788 ;; WE DEMAND LEXICAL SCOPING!!!
789 ;; WE DEMAND LEXICAL SCOPING!!!
790 ;; WE DEMAND LEXICAL SCOPING!!!
791 ;; WE DEMAND LEXICAL SCOPING!!!
792 ;; WE DEMAND LEXICAL SCOPING!!!
793 ;; WE DEMAND LEXICAL SCOPING!!!
794 ;; WE DEMAND LEXICAL SCOPING!!!
795 ;; WE DEMAND LEXICAL SCOPING!!!
796 ;; WE DEMAND LEXICAL SCOPING!!!
797 (defun frob-face-property (face property func &optional locale tags)
798 "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE.
799 This function is ugly and messy and is primarily used as an internal
800 helper function for `make-face-bold' et al., so you probably don't
801 want to use it or read the rest of the documentation. But if you do ...
803 FUNC should be a function of two arguments (an instance and a device)
804 that returns a modified name that is valid for the given device.
805 If LOCALE specifies a valid domain (i.e. a window, frame, or device),
806 this function instantiates the specifier over that domain, applies FUNC
807 to the resulting instance, and adds the result back as an instantiator
808 for that locale. Otherwise, LOCALE should be a locale, locale type, or
809 'all (defaults to 'all if omitted). For each specification thusly
810 included: if the locale given is a valid domain, FUNC will be
811 iterated over all valid instantiators for the device of the domain
812 until a non-nil result is found (if there is no such result, the
813 first valid instantiator is used), and that result substituted for
814 the specification; otherwise, the process just outlined is
815 iterated over each existing device and the concatenated results
816 substituted for the specification."
817 (let ((sp (face-property face property))
819 (if (valid-specifier-domain-p locale)
821 (let* ((inst (face-property-instance face property locale))
822 (name (and inst (funcall func inst (dfw-device locale)))))
824 (add-spec-to-specifier sp name locale tags)))
825 ;; otherwise, map over all specifications ...
826 ;; but first, some further kludging:
827 ;; (1) if we're frobbing the global property, make sure
828 ;; that something is there (copy from the default face,
829 ;; if necessary). Otherwise, something like
830 ;; (make-face-larger 'modeline)
831 ;; won't do anything at all if the modeline simply
832 ;; inherits its font from 'default.
833 ;; (2) if we're frobbing a particular locale, nothing would
834 ;; happen if that locale has no instantiators. So signal
835 ;; an error to indicate this.
838 (setq temp-sp (copy-specifier sp))
839 (if (and (or (eq locale 'global) (eq locale 'all) (not locale))
840 (not (face-property face property 'global)))
841 (copy-specifier (face-property 'default property)
843 (if (and (valid-specifier-locale-p locale)
844 (not (specifier-specs temp-sp locale)))
845 (error "Property must have a specification in locale %S" locale))
848 (lambda (sp-arg locale inst-list func)
849 (let* ((device (dfw-device locale))
850 ;; if a device can be derived from the locale,
851 ;; call frob-face-property-1 for that device.
852 ;; Otherwise map frob-face-property-1 over each device.
855 (list (frob-face-property-1 sp-arg device inst-list func))
856 (mapcar (lambda (device)
857 (frob-face-property-1 sp-arg device
861 ;; remove duplicates and nils from the obtained list of
862 ;; instantiators. Also add tags amd remove 'defaults'.
863 (mapcar (lambda (arg)
865 (if (not (consp arg))
866 (setq arg (cons tags arg))
867 (setcar arg (append tags (delete 'default
869 (when (and arg (not (member arg new-result)))
870 (setq new-result (cons arg new-result))))
873 (add-spec-list-to-specifier sp (list (cons locale new-result)))
874 ;; tell map-specifier to keep going.
879 (defun frob-face-property-1 (sp device inst-list func)
882 (while (and inst-list (not result))
883 (let* ((inst-pair (car inst-list))
884 (tag-set (car inst-pair))
885 (sp-inst (specifier-instance-from-inst-list
886 sp device (list inst-pair))))
889 (if (not first-valid)
890 (setq first-valid inst-pair))
891 (setq result (funcall func sp-inst device))
893 (setq result (cons tag-set result))))))
894 (setq inst-list (cdr inst-list)))
895 (or result first-valid)))
897 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
898 tty-thunk x-thunk standard-face-mapping)
899 ;; another kludge to make things more intuitive. If we're
900 ;; inheriting from a standard face in this locale, frob the
901 ;; inheritance as appropriate. Else, if, after the first X frobbing
902 ;; pass, the face hasn't changed and still looks like the standard
903 ;; unfrobbed face (e.g. 'default), make it inherit from the standard
904 ;; frobbed face (e.g. 'bold). Regardless of things, do the TTY
907 ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale,
908 ;; but is a "locale, locale-type, or nil for all". So ... do our extra
909 ;; frobbing only if it's actually a locale; or for nil, do the frobbing
910 ;; on 'global. This specifier stuff needs some rethinking.
911 (let* ((the-locale (cond ((null locale) 'global)
912 ((valid-specifier-locale-p locale) locale)
914 (specs (and the-locale (face-font face the-locale nil t)))
915 (change-it (and specs (cdr (assoc specs standard-face-mapping)))))
917 (not (memq (face-name (find-face face))
918 '(default bold italic bold-italic))))
920 (or (equal change-it t)
921 (set-face-property face 'font change-it the-locale))
923 (let* ((domain (cond ((null the-locale) nil)
924 ((valid-specifier-domain-p the-locale) the-locale)
925 ;; OK, this next one is truly a kludge, but
926 ;; it results in more intuitive behavior most
927 ;; of the time. (really!)
928 ((or (eq the-locale 'global) (eq the-locale 'all))
931 (inst (and domain (face-property-instance face 'font domain))))
934 ;; If it's reasonable to do the inherit-from-standard-face trick,
935 ;; and it's called for, then do it now.
937 (not (equal inst (face-property-instance face 'font domain)))
938 ;; don't do it for standard faces, or you'll get inheritance loops.
939 ;; #### This makes XEmacs seg fault! fix this bug.
940 (memq (face-name (find-face face))
941 '(default bold italic bold-italic))
942 (not (equal (face-property-instance face 'font domain)
943 (face-property-instance unfrobbed-face 'font domain)))
944 (set-face-property face 'font (vector frobbed-face)
945 the-locale tags))))))
947 (defun make-face-bold (face &optional locale tags)
948 "Make FACE bold in LOCALE, if possible.
949 This will attempt to make the font bold for X locales and will set the
950 highlight flag for TTY locales.
952 If LOCALE is nil, omitted, or `all', this will attempt to frob all
953 font specifications for FACE to make them appear bold. Similarly, if
954 LOCALE is a locale type, this frobs all font specifications for locales
955 of that type. If LOCALE is a particular locale, what happens depends on
956 what sort of locale is given. If you gave a device, frame, or window,
957 then it's always possible to determine what the font actually will be,
958 so this is determined and the resulting font is frobbed and added back as a
959 specification for this locale. If LOCALE is a buffer, however, you can't
960 determine what the font will actually be unless there's actually a
961 specification given for that particular buffer (otherwise, it depends
962 on what window and frame the buffer appears in, and might not even be
963 well-defined if the buffer appears multiple times in different places);
964 therefore you will get an error unless there's a specification for the
967 Finally, in some cases (specifically, when LOCALE is not a locale type),
968 if the frobbing didn't actually make the font look any different
969 \(this happens, for example, if your font specification is already bold
970 or has no bold equivalent), and currently looks like the font of the
971 'default face, it is set to inherit from the 'bold face. This is kludgy
972 but it makes `make-face-bold' have more intuitive behavior in many
974 (interactive (list (read-face-name "Make which face bold: ")))
976 face locale tags 'default 'bold
978 ;; handle TTY specific entries
979 (when (featurep 'tty)
980 (set-face-highlight-p face t locale (cons 'tty tags))))
982 ;; handle X specific entries
984 (frob-face-property face 'font 'x-make-font-bold locale tags))
985 (when (featurep 'mswindows)
986 (frob-face-property face 'font 'mswindows-make-font-bold locale tags))
988 '(([default] . [bold])
990 ([italic] . [bold-italic])
991 ([bold-italic] . t))))
993 (defun make-face-italic (face &optional locale tags)
994 "Make FACE italic in LOCALE, if possible.
995 This will attempt to make the font italic for X locales and will set
996 the underline flag for TTY locales.
997 See `make-face-bold' for the semantics of the LOCALE argument and
998 for more specifics on exactly how this function works."
999 (interactive (list (read-face-name "Make which face italic: ")))
1001 face locale tags 'default 'italic
1003 ;; handle TTY specific entries
1004 (when (featurep 'tty)
1005 (set-face-underline-p face t locale (cons 'tty tags))))
1007 ;; handle X specific entries
1009 (frob-face-property face 'font 'x-make-font-italic locale tags))
1010 (when (featurep 'mswindows)
1011 (frob-face-property face 'font 'mswindows-make-font-italic locale tags))
1013 '(([default] . [italic])
1014 ([bold] . [bold-italic])
1016 ([bold-italic] . t))))
1018 (defun make-face-bold-italic (face &optional locale tags)
1019 "Make FACE bold and italic in LOCALE, if possible.
1020 This will attempt to make the font bold-italic for X locales and will
1021 set the highlight and underline flags for TTY locales.
1022 See `make-face-bold' for the semantics of the LOCALE argument and
1023 for more specifics on exactly how this function works."
1024 (interactive (list (read-face-name "Make which face bold-italic: ")))
1026 face locale tags 'default 'bold-italic
1028 ;; handle TTY specific entries
1029 (when (featurep 'tty)
1030 (set-face-highlight-p face t locale (cons 'tty tags))
1031 (set-face-underline-p face t locale (cons 'tty tags))))
1033 ;; handle X specific entries
1035 (frob-face-property face 'font 'x-make-font-bold-italic locale tags))
1036 (when (featurep 'mswindows)
1037 (frob-face-property face 'font 'mswindows-make-font-bold-italic locale tags))
1039 '(([default] . [italic])
1040 ([bold] . [bold-italic])
1041 ([italic] . [bold-italic])
1042 ([bold-italic] . t))))
1044 (defun make-face-unbold (face &optional locale tags)
1045 "Make FACE non-bold in LOCALE, if possible.
1046 This will attempt to make the font non-bold for X locales and will
1047 unset the highlight flag for TTY locales.
1048 See `make-face-bold' for the semantics of the LOCALE argument and
1049 for more specifics on exactly how this function works."
1050 (interactive (list (read-face-name "Make which face non-bold: ")))
1052 face locale tags 'bold 'default
1054 ;; handle TTY specific entries
1055 (when (featurep 'tty)
1056 (set-face-highlight-p face nil locale (cons 'tty tags))))
1058 ;; handle X specific entries
1060 (frob-face-property face 'font 'x-make-font-unbold locale tags))
1061 (when (featurep 'mswindows)
1062 (frob-face-property face 'font 'mswindows-make-font-unbold locale tags))
1065 ([bold] . [default])
1067 ([bold-italic] . [italic]))))
1069 (defun make-face-unitalic (face &optional locale tags)
1070 "Make FACE non-italic in LOCALE, if possible.
1071 This will attempt to make the font non-italic for X locales and will
1072 unset the underline flag for TTY locales.
1073 See `make-face-bold' for the semantics of the LOCALE argument and
1074 for more specifics on exactly how this function works."
1075 (interactive (list (read-face-name "Make which face non-italic: ")))
1077 face locale tags 'italic 'default
1079 ;; handle TTY specific entries
1080 (when (featurep 'tty)
1081 (set-face-underline-p face nil locale (cons 'tty tags))))
1083 ;; handle X specific entries
1085 (frob-face-property face 'font 'x-make-font-unitalic locale tags))
1086 (when (featurep 'mswindows)
1087 (frob-face-property face 'font 'mswindows-make-font-unitalic locale tags))
1091 ([italic] . [default])
1092 ([bold-italic] . [bold]))))
1095 ;; Why do the following two functions lose so badly in so many
1098 (defun make-face-smaller (face &optional locale)
1099 "Make the font of FACE be smaller, if possible.
1100 LOCALE works as in `make-face-bold' et al., but the ``inheriting-
1101 from-the-bold-face'' operations described there are not done
1102 because they don't make sense in this context."
1103 (interactive (list (read-face-name "Shrink which face: ")))
1104 ;; handle X specific entries
1106 (frob-face-property face 'font 'x-find-smaller-font locale))
1107 (when (featurep 'mswindows)
1108 (frob-face-property face 'font 'mswindows-find-smaller-font locale)))
1110 (defun make-face-larger (face &optional locale)
1111 "Make the font of FACE be larger, if possible.
1112 See `make-face-smaller' for the semantics of the LOCALE argument."
1113 (interactive (list (read-face-name "Enlarge which face: ")))
1114 ;; handle X specific entries
1116 (frob-face-property face 'font 'x-find-larger-font locale))
1117 (when (featurep 'mswindows)
1118 (frob-face-property face 'font 'mswindows-find-larger-font locale)))
1120 (defun invert-face (face &optional locale)
1121 "Swap the foreground and background colors of the face."
1122 (interactive (list (read-face-name "Invert face: ")))
1123 (if (valid-specifier-domain-p locale)
1124 (let ((foreface (face-foreground-instance face locale)))
1125 (set-face-foreground face (face-background-instance face locale)
1127 (set-face-background face foreface locale))
1128 (let ((forespec (copy-specifier (face-foreground face) nil locale)))
1129 (copy-specifier (face-background face) (face-foreground face) locale)
1130 (copy-specifier forespec (face-background face) locale))))
1133 ;;; Convenience functions
1135 (defun face-ascent (face &optional domain charset)
1136 "Return the ascent of FACE in DOMAIN.
1137 See `face-property-instance' for the semantics of the DOMAIN argument."
1138 (font-ascent (face-font face) domain charset))
1140 (defun face-descent (face &optional domain charset)
1141 "Return the descent of FACE in DOMAIN.
1142 See `face-property-instance' for the semantics of the DOMAIN argument."
1143 (font-descent (face-font face) domain charset))
1145 (defun face-width (face &optional domain charset)
1146 "Return the width of FACE in DOMAIN.
1147 See `face-property-instance' for the semantics of the DOMAIN argument."
1148 (font-width (face-font face) domain charset))
1150 (defun face-height (face &optional domain charset)
1151 "Return the height of FACE in DOMAIN.
1152 See `face-property-instance' for the semantics of the DOMAIN argument."
1153 (+ (face-ascent face domain charset) (face-descent face domain charset)))
1155 (defun face-proportional-p (face &optional domain charset)
1156 "Return t if FACE is proportional in DOMAIN.
1157 See `face-property-instance' for the semantics of the DOMAIN argument."
1158 (font-proportional-p (face-font face) domain charset))
1161 ;; Functions that used to be in cus-face.el, but logically go here.
1163 (defcustom frame-background-mode nil
1164 "*The brightness of the background.
1165 Set this to the symbol dark if your background color is dark, light if
1166 your background is light, or nil (default) if you want Emacs to
1167 examine the brightness for you."
1169 :type '(choice (choice-item dark)
1171 (choice-item :tag "Auto" nil)))
1173 ;; The old variable that many people still have in .emacs files.
1174 (define-obsolete-variable-alias 'custom-background-mode
1175 'frame-background-mode)
1177 (defun get-frame-background-mode (frame)
1178 "Detect background mode for FRAME."
1179 (let* ((color-instance (face-background-instance 'default frame))
1180 (mode (condition-case nil
1181 (if (< (apply '+ (color-instance-rgb-components
1182 color-instance)) 65536)
1184 ;; Here, we get an error on a TTY. As we don't have
1185 ;; a good way of detecting whether a TTY is light or
1186 ;; dark, we'll guess it's dark.
1188 (set-frame-property frame 'background-mode mode)
1191 (defun extract-custom-frame-properties (frame)
1192 "Return a plist with the frame properties of FRAME used by custom."
1193 (list 'type (or (frame-property frame 'display-type)
1194 (device-type (frame-device frame)))
1195 'class (device-class (frame-device frame))
1196 'background (or frame-background-mode
1197 (frame-property frame 'background-mode)
1198 (get-frame-background-mode frame))))
1200 (defcustom init-face-from-resources t
1201 "If non nil, attempt to initialize faces from the resource database."
1205 ;; Old name, used by custom. Also, FSFmacs name.
1206 (defvaralias 'initialize-face-resources 'init-face-from-resources)
1208 ;; Make sure all custom setting are added with this tag so we can
1210 (define-specifier-tag 'custom)
1212 (defun face-spec-set (face spec &optional frame tags)
1213 "Set FACE's face attributes according to the first matching entry in SPEC.
1214 If optional FRAME is non-nil, set it for that frame only.
1215 If it is nil, then apply SPEC to each frame individually.
1216 See `defface' for information about SPEC."
1219 (reset-face face frame tags)
1220 (face-display-set face spec frame tags)
1221 (init-face-from-resources face frame))
1222 (let ((frames (relevant-custom-frames)))
1223 (reset-face face nil tags)
1224 ;; This should not be needed. We only remove our own specifiers
1225 ;; (if (and (eq 'default face) (featurep 'x))
1226 ;; (x-init-global-faces))
1227 (face-display-set face spec nil tags)
1229 (face-display-set face spec (car frames) tags)
1231 (init-face-from-resources face))))
1233 (defun face-display-set (face spec &optional frame tags)
1234 "Set FACE to the attributes to the first matching entry in SPEC.
1235 Iff optional FRAME is non-nil, set it for that frame only.
1236 See `defface' for information about SPEC."
1238 (let ((display (caar spec))
1239 (atts (cadar spec)))
1241 (when (face-spec-set-match-display display frame)
1242 ;; Avoid creating frame local duplicates of the global face.
1243 (unless (and frame (eq display (get face 'custom-face-display)))
1244 (apply 'face-custom-attributes-set face frame tags atts))
1246 (put face 'custom-face-display display))
1249 (defvar default-custom-frame-properties nil
1250 "The frame properties used for the global faces.
1251 Frames not matching these propertiess should have frame local faces.
1252 The value should be nil, if uninitialized, or a plist otherwise.
1253 See `defface' for a list of valid keys and values for the plist.")
1255 (defun get-custom-frame-properties (&optional frame)
1256 "Return a plist with the frame properties of FRAME used by custom.
1257 If FRAME is nil, return the default frame properties."
1259 ;; Try to get from cache.
1260 (let ((cache (frame-property frame 'custom-properties)))
1262 ;; Oh well, get it then.
1263 (setq cache (extract-custom-frame-properties frame))
1265 (set-frame-property frame 'custom-properties cache))
1267 (default-custom-frame-properties)
1269 (setq default-custom-frame-properties
1270 (extract-custom-frame-properties (selected-frame))))))
1272 (defun face-spec-update-all-matching (spec display plist)
1273 "Update all entries in the face spec that could match display to
1274 have the entries from the new plist and return the new spec"
1277 (let ((entries (car e))
1283 (unless (eq display t)
1285 (setq dplist (plist-put dplist (car arg) (cadr arg))))
1287 (unless (eq entries t)
1289 (setq match (and match (eq (cadr arg)
1298 (plist-put options (car new-options) (cadr new-options)))
1299 (setq new-options (cddr new-options)))
1300 (list entries options))))
1301 (copy-sequence spec)))
1305 (defun face-spec-set-match-display (display &optional frame)
1306 "Return non-nil if DISPLAY matches FRAME.
1307 DISPLAY is part of a spec such as can be used in `defface'.
1308 If FRAME is nil or omitted, the selected frame is used."
1311 (let* ((props (get-custom-frame-properties frame))
1312 (type (plist-get props 'type))
1313 (class (plist-get props 'class))
1314 (background (plist-get props 'background))
1318 (while (and entries match)
1319 (setq entry (car entries)
1320 entries (cdr entries)
1324 (type (memq type options))
1325 (class (memq class options))
1326 (background (memq background options))
1327 (t (warn "Unknown req `%S' with options `%S'"
1332 (defun relevant-custom-frames ()
1333 "List of frames whose custom properties differ from the default."
1334 (let ((relevant nil)
1335 (default (get-custom-frame-properties))
1336 (frames (frame-list))
1339 (setq frame (car frames)
1340 frames (cdr frames))
1341 (unless (equal default (get-custom-frame-properties frame))
1342 (push frame relevant)))
1345 (defun initialize-custom-faces (&optional frame)
1346 "Initialize all custom faces for FRAME.
1347 If FRAME is nil or omitted, initialize them for all frames."
1348 (mapc (lambda (symbol)
1349 (let ((spec (or (get symbol 'saved-face)
1350 (get symbol 'face-defface-spec))))
1352 ;; No need to init-face-from-resources -- code in
1353 ;; `init-frame-faces' does it already.
1354 (face-display-set symbol spec frame))))
1357 (defun custom-initialize-frame (frame)
1358 "Initialize frame-local custom faces for FRAME if necessary."
1359 (unless (equal (get-custom-frame-properties)
1360 (get-custom-frame-properties frame))
1361 (initialize-custom-faces frame)))
1363 (defun startup-initialize-custom-faces ()
1364 "Reset faces created by defface. Only called at startup.
1365 Don't use this function in your program."
1366 (when default-custom-frame-properties
1367 ;; Reset default value to the actual frame, not stream.
1368 (setq default-custom-frame-properties
1369 (extract-custom-frame-properties (selected-frame)))
1370 ;; like initialize-custom-faces but removes property first.
1371 (mapc (lambda (symbol)
1372 (let ((spec (or (get symbol 'saved-face)
1373 (get symbol 'face-defface-spec))))
1375 ;; Reset faces created during auto-autoloads loading.
1377 ;; And set it according to the spec.
1378 (face-display-set symbol spec nil))))
1382 (defun make-empty-face (name &optional doc-string temporary)
1383 "Like `make-face', but doesn't query the resource database."
1384 (let ((init-face-from-resources nil))
1385 (make-face name doc-string temporary)))
1387 (defun init-face-from-resources (face &optional locale)
1388 "Initialize FACE from the resource database.
1389 If LOCALE is specified, it should be a frame, device, or 'global, and
1390 the face will be resourced over that locale. Otherwise, the face will
1391 be resourced over all possible locales (i.e. all frames, all devices,
1393 (cond ((null init-face-from-resources)
1397 ;; Global, set for all frames.
1399 (init-face-from-resources face 'global)
1400 (let ((devices (device-list)))
1402 (init-face-from-resources face (car devices))
1403 (setq devices (cdr devices))))
1404 (let ((frames (frame-list)))
1406 (init-face-from-resources face (car frames))
1407 (setq frames (cdr frames))))))
1410 (let ((devtype (cond ((devicep locale) (device-type locale))
1411 ((framep locale) (frame-type locale))
1413 (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype))
1414 (x-init-face-from-resources face locale))
1415 ((or (not devtype) (eq 'tty devtype))
1416 ;; Nothing to do for TTYs?
1419 (defun init-device-faces (device)
1420 ;; First, add any device-local face resources.
1421 (when init-face-from-resources
1422 (loop for face in (face-list) do
1423 (init-face-from-resources face device))
1424 ;; Then do any device-specific initialization.
1425 (cond ((eq 'x (device-type device))
1426 (x-init-device-faces device))
1427 ((eq 'mswindows (device-type device))
1428 (mswindows-init-device-faces device))
1429 ;; Nothing to do for TTYs?
1431 (or (eq 'stream (device-type device))
1432 (init-other-random-faces device))))
1434 (defun init-frame-faces (frame)
1435 (when init-face-from-resources
1436 ;; First, add any frame-local face resources.
1437 (loop for face in (face-list) do
1438 (init-face-from-resources face frame))
1439 ;; Then do any frame-specific initialization.
1440 (cond ((eq 'x (frame-type frame))
1441 (x-init-frame-faces frame))
1442 ((eq 'mswindows (frame-type frame))
1443 (mswindows-init-frame-faces frame))
1444 ;; Is there anything which should be done for TTY's?
1447 ;; #### This is somewhat X-specific, and is called when the first
1448 ;; X device is created (even if there were TTY devices created
1449 ;; beforehand). The concept of resources has not been generalized
1450 ;; outside of X-specificness, so we have to live with this
1451 ;; breach of device-independence.
1453 (defun init-global-faces ()
1454 ;; Look for global face resources.
1455 (loop for face in (face-list) do
1456 (init-face-from-resources face 'global))
1457 ;; Further X frobbing.
1458 (x-init-global-faces)
1459 ;; for bold and the like, make the global specification be bold etc.
1460 ;; if the user didn't already specify a value. These will also be
1461 ;; frobbed further in init-other-random-faces.
1462 (unless (face-font 'bold 'global)
1463 (make-face-bold 'bold 'global))
1465 (unless (face-font 'italic 'global)
1466 (make-face-italic 'italic 'global))
1468 (unless (face-font 'bold-italic 'global)
1469 (make-face-bold-italic 'bold-italic 'global)
1470 (unless (face-font 'bold-italic 'global)
1471 (copy-face 'bold 'bold-italic)
1472 (make-face-italic 'bold-italic)))
1474 (when (face-equal 'bold 'bold-italic)
1475 (copy-face 'italic 'bold-italic)
1476 (make-face-bold 'bold-italic))
1478 ;; Nothing more to be done for X or TTY's?
1482 ;; These warnings are there for a reason. Just specify your fonts
1483 ;; correctly. Deal with it. Additionally, one can use
1484 ;; `log-warning-minimum-level' instead of this.
1485 ;(defvar inhibit-font-complaints nil
1486 ; "Whether to suppress complaints about incomplete sets of fonts.")
1488 (defun face-complain-about-font (face device)
1489 (if (symbolp face) (setq face (symbol-name face)))
1490 ;; (if (not inhibit-font-complaints)
1493 (let ((default-name (face-font-name 'default device)))
1494 (format "%s: couldn't deduce %s %s version of the font
1497 Please specify X resources to make the %s face
1498 visually distinguishable from the default face.
1499 For example, you could add one of the following to $HOME/Emacs:
1501 Emacs.%s.attributeFont: -dt-*-medium-i-*
1503 Emacs.%s.attributeForeground: hotpink\n"
1505 (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
1514 ;; #### This is quite a mess. We should use the custom mechanism for
1515 ;; most of this stuff. Currently we don't do it, because Custom
1516 ;; doesn't use specifiers (yet.) FSF does it the Right Way.
1518 ;; For instance, the definition of `bold' should be something like
1519 ;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should
1520 ;; make sure that everything works properly.
1522 (defun init-other-random-faces (device)
1523 "Initialize the colors and fonts of the bold, italic, bold-italic,
1524 zmacs-region, list-mode-item-selected, highlight, primary-selection,
1525 secondary-selection, and isearch faces when each device is created. If
1526 you want to add code to do stuff like this, use the create-device-hook."
1528 ;; try to make 'bold look different from the default on this device.
1529 ;; If that doesn't work at all, then issue a warning.
1530 (unless (face-differs-from-default-p 'bold device)
1531 (make-face-bold 'bold device)
1532 (unless (face-differs-from-default-p 'bold device)
1533 (make-face-unbold 'bold device)
1534 (unless (face-differs-from-default-p 'bold device)
1535 ;; the luser specified one of the bogus font names
1536 (face-complain-about-font 'bold device))))
1538 ;; Similar for italic.
1539 ;; It's unreasonable to expect to be able to make a font italic all
1540 ;; the time. For many languages, italic is an alien concept.
1541 ;; Basically, because italic is not a globally meaningful concept,
1542 ;; the use of the italic face should really be obsoleted.
1544 ;; I disagree with above. In many languages, the concept of capital
1545 ;; letters is just as alien, and yet we use them. Italic is here to
1548 ;; In a Solaris Japanese environment, there just aren't any italic
1549 ;; fonts - period. CDE recognizes this reality, and fonts
1550 ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come
1551 ;; in italic versions. So we first try to make the font bold before
1553 (unless (face-differs-from-default-p 'italic device)
1554 (make-face-italic 'italic device)
1555 (unless (face-differs-from-default-p 'italic device)
1556 (make-face-bold 'italic device)
1557 (unless (face-differs-from-default-p 'italic device)
1558 (face-complain-about-font 'italic device))))
1560 ;; similar for bold-italic.
1561 (unless (face-differs-from-default-p 'bold-italic device)
1562 (make-face-bold-italic 'bold-italic device)
1563 ;; if we couldn't get a bold-italic version, try just bold.
1564 (unless (face-differs-from-default-p 'bold-italic device)
1565 (make-face-bold 'bold-italic device)
1566 ;; if we couldn't get bold or bold-italic, then that's probably because
1567 ;; the default font is bold, so make the `bold-italic' face be unbold.
1568 (unless (face-differs-from-default-p 'bold-italic device)
1569 (make-face-unbold 'bold-italic device)
1570 (make-face-italic 'bold-italic device)
1571 (unless (face-differs-from-default-p 'bold-italic device)
1572 ;; if that didn't work, try plain italic
1573 ;; (can this ever happen? what the hell.)
1574 (make-face-italic 'bold-italic device)
1575 (unless (face-differs-from-default-p 'bold-italic device)
1576 ;; then bitch and moan.
1577 (face-complain-about-font 'bold-italic device))))))
1579 ;; Set the text-cursor colors unless already specified.
1580 (when (and (not (eq 'tty (device-type device)))
1581 (not (face-background 'text-cursor 'global))
1582 (face-property-equal 'text-cursor 'default 'background device))
1583 (set-face-background 'text-cursor [default foreground] 'global
1585 (when (and (not (eq 'tty (device-type device)))
1586 (not (face-foreground 'text-cursor 'global))
1587 (face-property-equal 'text-cursor 'default 'foreground device))
1588 (set-face-foreground 'text-cursor [default background] 'global
1592 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones.
1593 (defun set-face-stipple (face pixmap &optional frame)
1594 "Change the stipple pixmap of FACE to PIXMAP.
1595 This is an Emacs compatibility function; consider using
1596 set-face-background-pixmap instead.
1598 PIXMAP should be a string, the name of a file of pixmap data.
1599 The directories listed in the `x-bitmap-file-path' variable are searched.
1601 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT
1602 DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is
1603 a string, containing the raw bits of the bitmap. XBM data is
1604 expected in this case, other types of image data will not work.
1606 If the optional FRAME argument is provided, change only
1607 in that frame; otherwise change each frame."
1608 (while (not (find-face face))
1609 (setq face (signal 'wrong-type-argument (list 'facep face))))
1610 (locate-file pixmap x-bitmap-file-path '(".xbm" ""))
1611 (while (cond ((stringp pixmap)
1612 (unless (file-readable-p pixmap)
1613 (setq pixmap `[xbm :file ,pixmap]))
1615 ((and (consp pixmap) (= (length pixmap) 3))
1616 (setq pixmap `[xbm :data ,pixmap])
1619 (setq pixmap (signal 'wrong-type-argument
1620 (list 'stipple-pixmap-p pixmap))))
1621 (while (and frame (not (framep frame)))
1622 (setq frame (signal 'wrong-type-argument (list 'framep frame))))
1623 (set-face-background-pixmap face pixmap frame))
1626 ;; Create the remaining standard faces now. This way, packages that we dump
1627 ;; can reference these faces as parents.
1629 ;; The default, modeline, left-margin, right-margin, text-cursor,
1630 ;; and pointer faces are created in C.
1632 (make-face 'bold "Bold text.")
1633 (make-face 'italic "Italic text.")
1634 (make-face 'bold-italic "Bold-italic text.")
1635 (make-face 'underline "Underlined text.")
1636 (or (face-differs-from-default-p 'underline)
1637 (set-face-underline-p 'underline t 'global '(default)))
1638 (make-face 'zmacs-region "Used on highlightes region between point and mark.")
1639 (make-face 'isearch "Used on region matched by isearch.")
1640 (make-face 'isearch-secondary "Face to use for highlighting all matches.")
1641 (make-face 'list-mode-item-selected
1642 "Face for the selected list item in list-mode.")
1643 (make-face 'highlight "Highlight face.")
1644 (make-face 'primary-selection "Primary selection face.")
1645 (make-face 'secondary-selection "Secondary selection face.")
1647 ;; Several useful color faces.
1648 (eval-when-compile (load "cl-macs"))
1649 (dolist (color '(red green blue yellow))
1650 (make-face color (concat (symbol-name color) " text."))
1651 (set-face-foreground color (symbol-name color) nil 'color))
1653 ;; Make some useful faces. This happens very early, before creating
1654 ;; the first non-stream device.
1656 (set-face-background 'text-cursor
1657 '(((x default) . "Red3")
1658 ((mswindows default) . "Red3"))
1661 ;; some older X servers don't recognize "darkseagreen2"
1662 (set-face-background 'highlight
1663 '(((x default color) . "darkseagreen2")
1664 ((x default color) . "green")
1665 ((x default grayscale) . "gray53")
1666 ((mswindows default color) . "darkseagreen2")
1667 ((mswindows default color) . "green")
1668 ((mswindows default grayscale) . "gray53"))
1670 (set-face-background-pixmap 'highlight
1671 '(((x default mono) . "gray1")
1672 ((mswindows default mono) . "gray1"))
1675 (set-face-background 'zmacs-region
1676 '(((x default color) . "gray65")
1677 ((x default grayscale) . "gray65")
1678 ((mswindows default color) . "gray65")
1679 ((mswindows default grayscale) . "gray65"))
1681 (set-face-background-pixmap 'zmacs-region
1682 '(((x default mono) . "gray3")
1683 ((mswindows default mono) . "gray3"))
1686 (set-face-background 'list-mode-item-selected
1687 '(((x default color) . "gray68")
1688 ((x default grayscale) . "gray68")
1689 ((x default mono) . [default foreground])
1690 ((mswindows default color) . "gray68")
1691 ((mswindows default grayscale) . "gray68")
1692 ((mswindows default mono) . [default foreground]))
1694 (set-face-foreground 'list-mode-item-selected
1695 '(((x default mono) . [default background])
1696 ((mswindows default mono) . [default background]))
1699 (set-face-background 'primary-selection
1700 '(((x default color) . "gray65")
1701 ((x default grayscale) . "gray65")
1702 ((mswindows default color) . "gray65")
1703 ((mswindows default grayscale) . "gray65"))
1705 (set-face-background-pixmap 'primary-selection
1706 '(((x default mono) . "gray3")
1707 ((mswindows default mono) . "gray3"))
1710 (set-face-background 'secondary-selection
1711 '(((x default color) . "paleturquoise")
1712 ((x default color) . "green")
1713 ((x default grayscale) . "gray53")
1714 ((mswindows default color) . "paleturquoise")
1715 ((mswindows default color) . "green")
1716 ((mswindows default grayscale) . "gray53"))
1718 (set-face-background-pixmap 'secondary-selection
1719 '(((x default mono) . "gray1")
1720 ((mswindows default mono) . "gray1"))
1723 (set-face-background 'isearch
1724 '(((x default color) . "paleturquoise")
1725 ((x default color) . "green")
1726 ((mswindows default color) . "paleturquoise")
1727 ((mswindows default color) . "green"))
1730 ;; #### This should really, I mean *really*, be converted to some form
1731 ;; of `defface' one day.
1732 (set-face-foreground 'isearch-secondary
1733 '(((x default color) . "red3")
1734 ((mswindows default color) . "red3"))
1737 ;; Define some logical color names to be used when reading the pixmap files.
1739 (setq xpm-color-symbols
1741 (purecopy '("foreground" (face-foreground 'default)))
1742 (purecopy '("background" (face-background 'default)))
1743 (purecopy '("backgroundToolBarColor"
1747 (x-get-resource "backgroundToolBarColor"
1748 "BackgroundToolBarColor" 'string))
1750 (face-background 'toolbar))))
1751 (purecopy '("foregroundToolBarColor"
1755 (x-get-resource "foregroundToolBarColor"
1756 "ForegroundToolBarColor" 'string))
1757 (face-foreground 'toolbar))))
1760 (when (featurep 'tty)
1761 (set-face-highlight-p 'bold t 'global '(default tty))
1762 (set-face-underline-p 'italic t 'global '(default tty))
1763 (set-face-highlight-p 'bold-italic t 'global '(default tty))
1764 (set-face-underline-p 'bold-italic t 'global '(default tty))
1765 (set-face-highlight-p 'highlight t 'global '(default tty))
1766 (set-face-reverse-p 'text-cursor t 'global '(default tty))
1767 (set-face-reverse-p 'modeline t 'global '(default tty))
1768 (set-face-reverse-p 'zmacs-region t 'global '(default tty))
1769 (set-face-reverse-p 'primary-selection t 'global '(default tty))
1770 (set-face-underline-p 'secondary-selection t 'global '(default tty))
1771 (set-face-reverse-p 'list-mode-item-selected t 'global '(default tty))
1772 (set-face-reverse-p 'isearch t 'global '(default tty))
1775 ;;; faces.el ends here