Line data Source code
1 : ;;; faces.el --- Lisp faces -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 1992-1996, 1998-2017 Free Software Foundation, Inc.
4 :
5 : ;; Maintainer: emacs-devel@gnu.org
6 : ;; Keywords: internal
7 : ;; Package: emacs
8 :
9 : ;; This file is part of GNU Emacs.
10 :
11 : ;; GNU Emacs is free software: you can redistribute it and/or modify
12 : ;; it under the terms of the GNU General Public License as published by
13 : ;; the Free Software Foundation, either version 3 of the License, or
14 : ;; (at your option) any later version.
15 :
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.
20 :
21 : ;; You should have received a copy of the GNU General Public License
22 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 :
24 : ;;; Commentary:
25 :
26 : ;;; Code:
27 :
28 : (defcustom term-file-prefix (purecopy "term/")
29 : "If non-nil, Emacs startup performs terminal-specific initialization.
30 : It does this by: (load (concat term-file-prefix (getenv \"TERM\")))
31 :
32 : You may set this variable to nil in your init file if you do not wish
33 : the terminal-initialization file to be loaded."
34 : :type '(choice (const :tag "No terminal-specific initialization" nil)
35 : (string :tag "Name of directory with term files"))
36 : :group 'terminals)
37 :
38 : (defcustom term-file-aliases
39 : '(("apollo" . "vt100")
40 : ("vt102" . "vt100")
41 : ("vt125" . "vt100")
42 : ("vt201" . "vt200")
43 : ("vt220" . "vt200")
44 : ("vt240" . "vt200")
45 : ("vt300" . "vt200")
46 : ("vt320" . "vt200")
47 : ("vt400" . "vt200")
48 : ("vt420" . "vt200")
49 : )
50 : "Alist of terminal type aliases.
51 : Entries are of the form (TYPE . ALIAS), where both elements are strings.
52 : This means to treat a terminal of type TYPE as if it were of type ALIAS."
53 : :type '(alist :key-type (string :tag "Terminal")
54 : :value-type (string :tag "Alias"))
55 : :group 'terminals
56 : :version "25.1")
57 :
58 : (declare-function xw-defined-colors "term/common-win" (&optional frame))
59 :
60 : (defvar help-xref-stack-item)
61 :
62 : (defvar face-name-history nil
63 : "History list for some commands that read face names.
64 : Maximum length of the history list is determined by the value
65 : of `history-length', which see.")
66 :
67 :
68 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
69 : ;;; Font selection.
70 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
71 :
72 : (defgroup font-selection nil
73 : "Influencing face font selection."
74 : :group 'faces)
75 :
76 :
77 : (defcustom face-font-selection-order
78 : '(:width :height :weight :slant)
79 : "A list specifying how face font selection chooses fonts.
80 : Each of the four symbols `:width', `:height', `:weight', and `:slant'
81 : must appear once in the list, and the list must not contain any other
82 : elements. Font selection first tries to find a best matching font
83 : for those face attributes that appear before in the list. For
84 : example, if `:slant' appears before `:height', font selection first
85 : tries to find a font with a suitable slant, even if this results in
86 : a font height that isn't optimal."
87 : :tag "Font selection order"
88 : :type '(list symbol symbol symbol symbol)
89 : :group 'font-selection
90 : :set #'(lambda (symbol value)
91 : (set-default symbol value)
92 : (internal-set-font-selection-order value)))
93 :
94 :
95 : ;; In the absence of Fontconfig support, Monospace and Sans Serif are
96 : ;; unavailable, and we fall back on the courier and helv families,
97 : ;; which are generally available.
98 : (defcustom face-font-family-alternatives
99 : (mapcar (lambda (arg) (mapcar 'purecopy arg))
100 : '(("Monospace" "courier" "fixed")
101 :
102 : ;; Monospace Serif is an Emacs invention, intended to work around
103 : ;; portability problems when using Courier. It should work well
104 : ;; when combined with Monospaced and with other standard fonts.
105 : ;; One of its uses is for 'tex-verbatim' and 'Info-quoted' faces,
106 : ;; so the result must be different from the default face's font,
107 : ;; and must be monospaced. For 'tex-verbatim', it is desirable
108 : ;; that the font really is a Serif font, so as to look like
109 : ;; TeX's 'verbatim'.
110 : ("Monospace Serif"
111 :
112 : ;; This looks good on GNU/Linux.
113 : "Courier 10 Pitch"
114 : ;; This looks good on MS-Windows and OS X. Note that this is
115 : ;; actually a sans-serif font, but it's here for lack of a better
116 : ;; alternative.
117 : "Consolas"
118 : ;; This looks good on macOS. "Courier" looks good too, but is
119 : ;; jagged on GNU/Linux and so is listed later as "courier".
120 : "Courier Std"
121 : ;; Although these are anti-aliased, they are a bit faint compared
122 : ;; to the above.
123 : "FreeMono" "Nimbus Mono L"
124 : ;; These are aliased and look jagged.
125 : "courier" "fixed"
126 : ;; Omit Courier New, as it is the default MS-Windows font and so
127 : ;; would look no different, and is pretty faint on other platforms.
128 : )
129 :
130 : ;; This is present for backward compatibility.
131 : ("courier" "CMU Typewriter Text" "fixed")
132 :
133 : ("Sans Serif" "helv" "helvetica" "arial" "fixed")
134 : ("helv" "helvetica" "arial" "fixed")))
135 : "Alist of alternative font family names.
136 : Each element has the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...).
137 : If fonts of family FAMILY can't be loaded, try ALTERNATIVE1, then
138 : ALTERNATIVE2 etc."
139 : :tag "Alternative font families to try"
140 : :type '(repeat (repeat string))
141 : :group 'font-selection
142 : :set #'(lambda (symbol value)
143 : (set-default symbol value)
144 : (internal-set-alternative-font-family-alist value)))
145 :
146 :
147 : ;; This is defined originally in xfaces.c.
148 : (defcustom face-font-registry-alternatives
149 : (mapcar (lambda (arg) (mapcar 'purecopy arg))
150 : (if (featurep 'w32)
151 : '(("iso8859-1" "ms-oemlatin")
152 : ("gb2312.1980" "gb2312" "gbk" "gb18030")
153 : ("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
154 : ("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
155 : ("muletibetan-2" "muletibetan-0"))
156 : '(("gb2312.1980" "gb2312.80&gb8565.88" "gbk" "gb18030")
157 : ("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
158 : ("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
159 : ("muletibetan-2" "muletibetan-0"))))
160 : "Alist of alternative font registry names.
161 : Each element has the form (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...).
162 : If fonts of registry REGISTRY can be loaded, font selection
163 : tries to find a best matching font among all fonts of registry
164 : REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc."
165 : :tag "Alternative font registries to try"
166 : :type '(repeat (repeat string))
167 : :version "21.1"
168 : :group 'font-selection
169 : :set #'(lambda (symbol value)
170 : (set-default symbol value)
171 : (internal-set-alternative-font-registry-alist value)))
172 :
173 :
174 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
175 : ;;; Creation, copying.
176 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
177 :
178 :
179 : (defun face-list ()
180 : "Return a list of all defined faces."
181 3 : (mapcar #'car face-new-frame-defaults))
182 :
183 : (defun make-face (face)
184 : "Define a new face with name FACE, a symbol.
185 : Do not call this directly from Lisp code; use `defface' instead.
186 :
187 : If FACE is already known as a face, leave it unmodified. Return FACE."
188 0 : (interactive (list (read-from-minibuffer
189 0 : "Make face: " nil nil t 'face-name-history)))
190 2 : (unless (facep face)
191 : ;; Make frame-local faces (this also makes the global one).
192 2 : (dolist (frame (frame-list))
193 2 : (internal-make-lisp-face face frame))
194 : ;; Add the face to the face menu.
195 2 : (when (fboundp 'facemenu-add-new-face)
196 2 : (facemenu-add-new-face face))
197 : ;; Define frame-local faces for all frames from X resources.
198 2 : (make-face-x-resource-internal face))
199 2 : face)
200 :
201 : (defun make-empty-face (face)
202 : "Define a new, empty face with name FACE.
203 : Do not call this directly from Lisp code; use `defface' instead."
204 0 : (interactive (list (read-from-minibuffer
205 0 : "Make empty face: " nil nil t 'face-name-history)))
206 2 : (make-face face))
207 :
208 : (defun copy-face (old-face new-face &optional frame new-frame)
209 : "Define a face named NEW-FACE, which is a copy of OLD-FACE.
210 : This function does not copy face customization data, so NEW-FACE
211 : will not be made customizable. Most Lisp code should not call
212 : this function; use `defface' with :inherit instead.
213 :
214 : If NEW-FACE already exists as a face, modify it to be like
215 : OLD-FACE. If NEW-FACE doesn't already exist, create it.
216 :
217 : If the optional argument FRAME is a frame, change NEW-FACE on
218 : FRAME only. If FRAME is t, copy the frame-independent default
219 : specification for OLD-FACE to NEW-FACE. If FRAME is nil, copy
220 : the defaults as well as the faces on each existing frame.
221 :
222 : If the optional fourth argument NEW-FRAME is given, copy the
223 : information from face OLD-FACE on frame FRAME to NEW-FACE on
224 : frame NEW-FRAME. In this case, FRAME must not be nil."
225 0 : (let ((inhibit-quit t))
226 0 : (if (null frame)
227 0 : (progn
228 0 : (when new-frame
229 0 : (error "Copying face %s from all frames to one frame"
230 0 : old-face))
231 0 : (make-empty-face new-face)
232 0 : (dolist (frame (frame-list))
233 0 : (copy-face old-face new-face frame))
234 0 : (copy-face old-face new-face t))
235 0 : (make-empty-face new-face)
236 0 : (internal-copy-lisp-face old-face new-face frame new-frame))
237 0 : new-face))
238 :
239 :
240 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241 : ;;; Predicates, type checks.
242 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
243 :
244 : (defun facep (face)
245 : "Return non-nil if FACE is a face name; nil otherwise.
246 : A face name can be a string or a symbol."
247 2 : (internal-lisp-face-p face))
248 :
249 :
250 : (defun check-face (face)
251 : "Signal an error if FACE doesn't name a face.
252 : Value is FACE."
253 0 : (unless (facep face)
254 0 : (error "Not a face: %s" face))
255 0 : face)
256 :
257 :
258 : ;; The ID returned is not to be confused with the internally used IDs
259 : ;; of realized faces. The ID assigned to Lisp faces is used to
260 : ;; support faces in display table entries.
261 :
262 : (defun face-id (face &optional _frame)
263 : "Return the internal ID of face with name FACE.
264 : If FACE is a face-alias, return the ID of the target face.
265 : The optional argument FRAME is ignored, since the internal face ID
266 : of a face name is the same for all frames."
267 0 : (check-face face)
268 0 : (or (get face 'face)
269 0 : (face-id (get face 'face-alias))))
270 :
271 : (defun face-equal (face1 face2 &optional frame)
272 : "Non-nil if faces FACE1 and FACE2 are equal.
273 : Faces are considered equal if all their attributes are equal.
274 : If the optional argument FRAME is given, report on FACE1 and FACE2 in that frame.
275 : If FRAME is t, report on the defaults for FACE1 and FACE2 (for new frames).
276 : If FRAME is omitted or nil, use the selected frame."
277 0 : (internal-lisp-face-equal-p face1 face2 frame))
278 :
279 :
280 : (defun face-differs-from-default-p (face &optional frame)
281 : "Return non-nil if FACE displays differently from the default face.
282 : If the optional argument FRAME is given, report on face FACE in that frame.
283 : If FRAME is t, report on the defaults for face FACE (for new frames).
284 : If FRAME is omitted or nil, use the selected frame."
285 0 : (let ((attrs
286 0 : (delq :inherit (mapcar 'car face-attribute-name-alist)))
287 : (differs nil))
288 0 : (while (and attrs (not differs))
289 0 : (let* ((attr (pop attrs))
290 0 : (attr-val (face-attribute face attr frame t)))
291 0 : (when (and
292 0 : (not (eq attr-val 'unspecified))
293 0 : (display-supports-face-attributes-p (list attr attr-val)
294 0 : frame))
295 0 : (setq differs attr))))
296 0 : differs))
297 :
298 :
299 : (defun face-nontrivial-p (face &optional frame)
300 : "True if face FACE has some non-nil attribute.
301 : If the optional argument FRAME is given, report on face FACE in that frame.
302 : If FRAME is t, report on the defaults for face FACE (for new frames).
303 : If FRAME is omitted or nil, use the selected frame."
304 0 : (not (internal-lisp-face-empty-p face frame)))
305 :
306 :
307 : (defun face-list-p (face-or-list)
308 : "True if FACE-OR-LIST is a list of faces.
309 : Return nil if FACE-OR-LIST is a non-nil atom, or a cons cell whose car
310 : is either `foreground-color', `background-color', or a keyword."
311 : ;; The logic of merge_face_ref (xfaces.c) is recreated here.
312 0 : (and (listp face-or-list)
313 0 : (not (memq (car face-or-list)
314 0 : '(foreground-color background-color)))
315 0 : (not (keywordp (car face-or-list)))))
316 :
317 :
318 :
319 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
320 : ;;; Setting face attributes from X resources.
321 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
322 :
323 : (defcustom face-x-resources
324 : (mapcar
325 : (lambda (arg)
326 : ;; FIXME; can we purecopy some of the conses too?
327 : (cons (car arg)
328 : (cons (purecopy (car (cdr arg))) (purecopy (cdr (cdr arg))))))
329 : '((:family (".attributeFamily" . "Face.AttributeFamily"))
330 : (:foundry (".attributeFoundry" . "Face.AttributeFoundry"))
331 : (:width (".attributeWidth" . "Face.AttributeWidth"))
332 : (:height (".attributeHeight" . "Face.AttributeHeight"))
333 : (:weight (".attributeWeight" . "Face.AttributeWeight"))
334 : (:slant (".attributeSlant" . "Face.AttributeSlant"))
335 : (:foreground (".attributeForeground" . "Face.AttributeForeground"))
336 : (:distant-foreground
337 : (".attributeDistantForeground" . "Face.AttributeDistantForeground"))
338 : (:background (".attributeBackground" . "Face.AttributeBackground"))
339 : (:overline (".attributeOverline" . "Face.AttributeOverline"))
340 : (:strike-through (".attributeStrikeThrough" . "Face.AttributeStrikeThrough"))
341 : (:box (".attributeBox" . "Face.AttributeBox"))
342 : (:underline (".attributeUnderline" . "Face.AttributeUnderline"))
343 : (:inverse-video (".attributeInverse" . "Face.AttributeInverse"))
344 : (:stipple
345 : (".attributeStipple" . "Face.AttributeStipple")
346 : (".attributeBackgroundPixmap" . "Face.AttributeBackgroundPixmap"))
347 : (:bold (".attributeBold" . "Face.AttributeBold"))
348 : (:italic (".attributeItalic" . "Face.AttributeItalic"))
349 : (:font (".attributeFont" . "Face.AttributeFont"))
350 : (:inherit (".attributeInherit" . "Face.AttributeInherit"))))
351 : "List of X resources and classes for face attributes.
352 : Each element has the form (ATTRIBUTE ENTRY1 ENTRY2...) where ATTRIBUTE is
353 : the name of a face attribute, and each ENTRY is a cons of the form
354 : \(RESOURCE . CLASS) with RESOURCE being the resource and CLASS being the
355 : X resource class for the attribute."
356 : :type '(repeat (cons symbol (repeat (cons string string))))
357 : :group 'faces)
358 :
359 :
360 : (declare-function internal-face-x-get-resource "xfaces.c"
361 : (resource class &optional frame))
362 :
363 : (declare-function internal-set-lisp-face-attribute-from-resource "xfaces.c"
364 : (face attr value &optional frame))
365 :
366 : (defun set-face-attribute-from-resource (face attribute resource class frame)
367 : "Set FACE's ATTRIBUTE from X resource RESOURCE, class CLASS on FRAME.
368 : Value is the attribute value specified by the resource, or nil
369 : if not present. This function displays a message if the resource
370 : specifies an invalid attribute."
371 0 : (let* ((face-name (face-name face))
372 0 : (value (internal-face-x-get-resource (concat face-name resource)
373 0 : class frame)))
374 0 : (when value
375 0 : (condition-case ()
376 0 : (internal-set-lisp-face-attribute-from-resource
377 0 : face attribute (downcase value) frame)
378 : (error
379 0 : (message "Face %s, frame %s: invalid attribute %s %s from X resource"
380 0 : face-name frame attribute value))))
381 0 : value))
382 :
383 :
384 : (defun set-face-attributes-from-resources (face frame)
385 : "Set attributes of FACE from X resources for FRAME."
386 131 : (when (memq (framep frame) '(x w32))
387 0 : (dolist (definition face-x-resources)
388 0 : (let ((attribute (car definition)))
389 0 : (dolist (entry (cdr definition))
390 0 : (set-face-attribute-from-resource face attribute (car entry)
391 131 : (cdr entry) frame))))))
392 :
393 :
394 : (defun make-face-x-resource-internal (face &optional frame)
395 : "Fill frame-local FACE on FRAME from X resources.
396 : FRAME nil or not specified means do it for all frames.
397 :
398 : If `inhibit-x-resources' is non-nil, this function does nothing."
399 131 : (unless inhibit-x-resources
400 131 : (dolist (frame (if (null frame) (frame-list) (list frame)))
401 : ;; `x-create-frame' already took care of correctly handling
402 : ;; the reverse video case-- do _not_ touch the default face
403 131 : (unless (and (eq face 'default)
404 131 : (frame-parameter frame 'reverse))
405 131 : (set-face-attributes-from-resources face frame)))))
406 :
407 :
408 :
409 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
410 : ;;; Retrieving face attributes.
411 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
412 :
413 : (defun face-name (face)
414 : "Return the name of face FACE."
415 0 : (symbol-name (check-face face)))
416 :
417 :
418 : (defun face-all-attributes (face &optional frame)
419 : "Return an alist stating the attributes of FACE.
420 : Each element of the result has the form (ATTR-NAME . ATTR-VALUE).
421 : If FRAME is omitted or nil the value describes the default attributes,
422 : but if you specify FRAME, the value describes the attributes
423 : of FACE on FRAME."
424 0 : (mapcar (lambda (pair)
425 0 : (let ((attr (car pair)))
426 0 : (cons attr (face-attribute face attr (or frame t)))))
427 0 : face-attribute-name-alist))
428 :
429 : (defun face-attribute (face attribute &optional frame inherit)
430 : "Return the value of FACE's ATTRIBUTE on FRAME.
431 : If the optional argument FRAME is given, report on face FACE in that frame.
432 : If FRAME is t, report on the defaults for face FACE (for new frames).
433 : If FRAME is omitted or nil, use the selected frame.
434 :
435 : If INHERIT is nil, only attributes directly defined by FACE are considered,
436 : so the return value may be `unspecified', or a relative value.
437 : If INHERIT is non-nil, FACE's definition of ATTRIBUTE is merged with the
438 : faces specified by its `:inherit' attribute; however the return value
439 : may still be `unspecified' or relative.
440 : If INHERIT is a face or a list of faces, then the result is further merged
441 : with that face (or faces), until it becomes specified and absolute.
442 :
443 : To ensure that the return value is always specified and absolute, use a
444 : value of `default' for INHERIT; this will resolve any unspecified or
445 : relative values by merging with the `default' face (which is always
446 : completely specified)."
447 1912 : (let ((value (internal-get-lisp-face-attribute face attribute frame)))
448 1912 : (when (and inherit (face-attribute-relative-p attribute value))
449 : ;; VALUE is relative, so merge with inherited faces
450 0 : (let ((inh-from (face-attribute face :inherit frame)))
451 0 : (unless (or (null inh-from) (eq inh-from 'unspecified))
452 0 : (condition-case nil
453 0 : (setq value
454 0 : (face-attribute-merged-with attribute value inh-from frame))
455 : ;; The `inherit' attribute may point to non existent faces.
456 1912 : (error nil)))))
457 1912 : (when (and inherit
458 0 : (not (eq inherit t))
459 1912 : (face-attribute-relative-p attribute value))
460 : ;; We should merge with INHERIT as well
461 1912 : (setq value (face-attribute-merged-with attribute value inherit frame)))
462 1912 : value))
463 :
464 : (defun face-attribute-merged-with (attribute value faces &optional frame)
465 : "Merges ATTRIBUTE, initially VALUE, with faces from FACES until absolute.
466 : FACES may be either a single face or a list of faces.
467 : [This is an internal function.]"
468 0 : (cond ((not (face-attribute-relative-p attribute value))
469 0 : value)
470 0 : ((null faces)
471 0 : value)
472 0 : ((consp faces)
473 0 : (face-attribute-merged-with
474 0 : attribute
475 0 : (face-attribute-merged-with attribute value (car faces) frame)
476 0 : (cdr faces)
477 0 : frame))
478 : (t
479 0 : (merge-face-attribute attribute
480 0 : value
481 0 : (face-attribute faces attribute frame t)))))
482 :
483 :
484 : (defmacro face-attribute-specified-or (value &rest body)
485 : "Return VALUE, unless it's `unspecified', in which case evaluate BODY and return the result."
486 5 : (let ((temp (make-symbol "value")))
487 5 : `(let ((,temp ,value))
488 5 : (if (not (eq ,temp 'unspecified))
489 5 : ,temp
490 5 : ,@body))))
491 :
492 : (defun face-foreground (face &optional frame inherit)
493 : "Return the foreground color name of FACE, or nil if unspecified.
494 : If the optional argument FRAME is given, report on face FACE in that frame.
495 : If FRAME is t, report on the defaults for face FACE (for new frames).
496 : If FRAME is omitted or nil, use the selected frame.
497 :
498 : If INHERIT is nil, only a foreground color directly defined by FACE is
499 : considered, so the return value may be nil.
500 : If INHERIT is t, and FACE doesn't define a foreground color, then any
501 : foreground color that FACE inherits through its `:inherit' attribute
502 : is considered as well; however the return value may still be nil.
503 : If INHERIT is a face or a list of faces, then it is used to try to
504 : resolve an unspecified foreground color.
505 :
506 : To ensure that a valid color is always returned, use a value of
507 : `default' for INHERIT; this will resolve any unspecified values by
508 : merging with the `default' face (which is always completely specified)."
509 0 : (face-attribute-specified-or (face-attribute face :foreground frame inherit)
510 0 : nil))
511 :
512 : (defun face-background (face &optional frame inherit)
513 : "Return the background color name of FACE, or nil if unspecified.
514 : If the optional argument FRAME is given, report on face FACE in that frame.
515 : If FRAME is t, report on the defaults for face FACE (for new frames).
516 : If FRAME is omitted or nil, use the selected frame.
517 :
518 : If INHERIT is nil, only a background color directly defined by FACE is
519 : considered, so the return value may be nil.
520 : If INHERIT is t, and FACE doesn't define a background color, then any
521 : background color that FACE inherits through its `:inherit' attribute
522 : is considered as well; however the return value may still be nil.
523 : If INHERIT is a face or a list of faces, then it is used to try to
524 : resolve an unspecified background color.
525 :
526 : To ensure that a valid color is always returned, use a value of
527 : `default' for INHERIT; this will resolve any unspecified values by
528 : merging with the `default' face (which is always completely specified)."
529 0 : (face-attribute-specified-or (face-attribute face :background frame inherit)
530 0 : nil))
531 :
532 : (defun face-stipple (face &optional frame inherit)
533 : "Return the stipple pixmap name of FACE, or nil if unspecified.
534 : If the optional argument FRAME is given, report on face FACE in that frame.
535 : If FRAME is t, report on the defaults for face FACE (for new frames).
536 : If FRAME is omitted or nil, use the selected frame.
537 :
538 : If INHERIT is nil, only a stipple directly defined by FACE is
539 : considered, so the return value may be nil.
540 : If INHERIT is t, and FACE doesn't define a stipple, then any stipple
541 : that FACE inherits through its `:inherit' attribute is considered as
542 : well; however the return value may still be nil.
543 : If INHERIT is a face or a list of faces, then it is used to try to
544 : resolve an unspecified stipple.
545 :
546 : To ensure that a valid stipple or nil is always returned, use a value of
547 : `default' for INHERIT; this will resolve any unspecified values by merging
548 : with the `default' face (which is always completely specified)."
549 0 : (face-attribute-specified-or (face-attribute face :stipple frame inherit)
550 0 : nil))
551 :
552 :
553 : (defalias 'face-background-pixmap 'face-stipple)
554 :
555 :
556 : (defun face-underline-p (face &optional frame inherit)
557 : "Return non-nil if FACE specifies a non-nil underlining.
558 : If the optional argument FRAME is given, report on face FACE in that frame.
559 : If FRAME is t, report on the defaults for face FACE (for new frames).
560 : If FRAME is omitted or nil, use the selected frame.
561 : Optional argument INHERIT is passed to `face-attribute'."
562 0 : (face-attribute-specified-or
563 0 : (face-attribute face :underline frame inherit) nil))
564 :
565 :
566 : (defun face-inverse-video-p (face &optional frame inherit)
567 : "Return non-nil if FACE specifies a non-nil inverse-video.
568 : If the optional argument FRAME is given, report on face FACE in that frame.
569 : If FRAME is t, report on the defaults for face FACE (for new frames).
570 : If FRAME is omitted or nil, use the selected frame.
571 : Optional argument INHERIT is passed to `face-attribute'."
572 0 : (eq (face-attribute face :inverse-video frame inherit) t))
573 :
574 :
575 : (defun face-bold-p (face &optional frame inherit)
576 : "Return non-nil if the font of FACE is bold on FRAME.
577 : If the optional argument FRAME is given, report on face FACE in that frame.
578 : If FRAME is t, report on the defaults for face FACE (for new frames).
579 : If FRAME is omitted or nil, use the selected frame.
580 : Optional argument INHERIT is passed to `face-attribute'.
581 : Use `face-attribute' for finer control."
582 0 : (let ((bold (face-attribute face :weight frame inherit)))
583 0 : (memq bold '(semi-bold bold extra-bold ultra-bold))))
584 :
585 :
586 : (defun face-italic-p (face &optional frame inherit)
587 : "Return non-nil if the font of FACE is italic on FRAME.
588 : If the optional argument FRAME is given, report on face FACE in that frame.
589 : If FRAME is t, report on the defaults for face FACE (for new frames).
590 : If FRAME is omitted or nil, use the selected frame.
591 : Optional argument INHERIT is passed to `face-attribute'.
592 : Use `face-attribute' for finer control."
593 0 : (let ((italic (face-attribute face :slant frame inherit)))
594 0 : (memq italic '(italic oblique))))
595 :
596 :
597 :
598 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
599 : ;;; Face documentation.
600 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601 :
602 : (defun face-documentation (face)
603 : "Get the documentation string for FACE.
604 : If FACE is a face-alias, get the documentation for the target face."
605 0 : (let ((alias (get face 'face-alias)))
606 0 : (if alias
607 0 : (let ((doc (get alias 'face-documentation)))
608 0 : (format "%s is an alias for the face `%s'.%s" face alias
609 0 : (if doc (format "\n%s" doc)
610 0 : "")))
611 0 : (get face 'face-documentation))))
612 :
613 :
614 : (defun set-face-documentation (face string)
615 : "Set the documentation string for FACE to STRING."
616 : ;; Perhaps the text should go in DOC.
617 2 : (put face 'face-documentation (purecopy string)))
618 :
619 :
620 : (defalias 'face-doc-string 'face-documentation)
621 : (defalias 'set-face-doc-string 'set-face-documentation)
622 :
623 :
624 :
625 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
626 : ;; Setting face attributes.
627 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
628 :
629 :
630 : (defun set-face-attribute (face frame &rest args)
631 : "Set attributes of FACE on FRAME from ARGS.
632 : This function overrides the face attributes specified by FACE's
633 : face spec. It is mostly intended for internal use only.
634 :
635 : If FRAME is nil, set the attributes for all existing frames, as
636 : well as the default for new frames. If FRAME is t, change the
637 : default for new frames only.
638 :
639 : ARGS must come in pairs ATTRIBUTE VALUE. ATTRIBUTE must be a
640 : valid face attribute name. All attributes can be set to
641 : `unspecified'; this fact is not further mentioned below.
642 :
643 : The following attributes are recognized:
644 :
645 : `:family'
646 :
647 : VALUE must be a string specifying the font family
648 : \(e.g. \"Monospace\") or a fontset.
649 :
650 : `:foundry'
651 :
652 : VALUE must be a string specifying the font foundry,
653 : e.g., \"adobe\". If a font foundry is specified, wild-cards `*'
654 : and `?' are allowed.
655 :
656 : `:width'
657 :
658 : VALUE specifies the relative proportionate width of the font to use.
659 : It must be one of the symbols `ultra-condensed', `extra-condensed',
660 : `condensed', `semi-condensed', `normal', `semi-expanded', `expanded',
661 : `extra-expanded', or `ultra-expanded'.
662 :
663 : `:height'
664 :
665 : VALUE specifies the relative or absolute height of the font. An
666 : absolute height is an integer, and specifies font height in units
667 : of 1/10 pt. A relative height is either a floating point number,
668 : which specifies a scaling factor for the underlying face height;
669 : or a function that takes a single argument (the underlying face
670 : height) and returns the new height. Note that for the `default'
671 : face, you must specify an absolute height (since there is nothing
672 : for it to be relative to).
673 :
674 : `:weight'
675 :
676 : VALUE specifies the weight of the font to use. It must be one of the
677 : symbols `ultra-bold', `extra-bold', `bold', `semi-bold', `normal',
678 : `semi-light', `light', `extra-light', `ultra-light'.
679 :
680 : `:slant'
681 :
682 : VALUE specifies the slant of the font to use. It must be one of the
683 : symbols `italic', `oblique', `normal', `reverse-italic', or
684 : `reverse-oblique'.
685 :
686 : `:foreground', `:background'
687 :
688 : VALUE must be a color name, a string.
689 :
690 : `:underline'
691 :
692 : VALUE specifies whether characters in FACE should be underlined.
693 : If VALUE is t, underline with foreground color of the face.
694 : If VALUE is a string, underline with that color.
695 : If VALUE is nil, explicitly don't underline.
696 :
697 : Otherwise, VALUE must be a property list of the form:
698 :
699 : `(:color COLOR :style STYLE)'.
700 :
701 : COLOR can be a either a color name string or `foreground-color'.
702 : STYLE can be either `line' or `wave'.
703 : If a keyword/value pair is missing from the property list, a
704 : default value will be used for the value.
705 : The default value of COLOR is the foreground color of the face.
706 : The default value of STYLE is `line'.
707 :
708 : `:overline'
709 :
710 : VALUE specifies whether characters in FACE should be overlined. If
711 : VALUE is t, overline with foreground color of the face. If VALUE is a
712 : string, overline with that color. If VALUE is nil, explicitly don't
713 : overline.
714 :
715 : `:strike-through'
716 :
717 : VALUE specifies whether characters in FACE should be drawn with a line
718 : striking through them. If VALUE is t, use the foreground color of the
719 : face. If VALUE is a string, strike-through with that color. If VALUE
720 : is nil, explicitly don't strike through.
721 :
722 : `:box'
723 :
724 : VALUE specifies whether characters in FACE should have a box drawn
725 : around them. If VALUE is nil, explicitly don't draw boxes. If
726 : VALUE is t, draw a box with lines of width 1 in the foreground color
727 : of the face. If VALUE is a string, the string must be a color name,
728 : and the box is drawn in that color with a line width of 1. Otherwise,
729 : VALUE must be a property list of the form `(:line-width WIDTH
730 : :color COLOR :style STYLE)'. If a keyword/value pair is missing from
731 : the property list, a default value will be used for the value, as
732 : specified below. WIDTH specifies the width of the lines to draw; it
733 : defaults to 1. If WIDTH is negative, the absolute value is the width
734 : of the lines, and draw top/bottom lines inside the characters area,
735 : not around it. COLOR is the name of the color to draw in, default is
736 : the foreground color of the face for simple boxes, and the background
737 : color of the face for 3D boxes. STYLE specifies whether a 3D box
738 : should be draw. If STYLE is `released-button', draw a box looking
739 : like a released 3D button. If STYLE is `pressed-button' draw a box
740 : that appears like a pressed button. If STYLE is nil, the default if
741 : the property list doesn't contain a style specification, draw a 2D
742 : box.
743 :
744 : `:inverse-video'
745 :
746 : VALUE specifies whether characters in FACE should be displayed in
747 : inverse video. VALUE must be one of t or nil.
748 :
749 : `:stipple'
750 :
751 : If VALUE is a string, it must be the name of a file of pixmap data.
752 : The directories listed in the `x-bitmap-file-path' variable are
753 : searched. Alternatively, VALUE may be a list of the form (WIDTH
754 : HEIGHT DATA) where WIDTH and HEIGHT are the size in pixels, and DATA
755 : is a string containing the raw bits of the bitmap. VALUE nil means
756 : explicitly don't use a stipple pattern.
757 :
758 : For convenience, attributes `:family', `:foundry', `:width',
759 : `:height', `:weight', and `:slant' may also be set in one step
760 : from an X font name:
761 :
762 : `:font'
763 :
764 : Set font-related face attributes from VALUE. VALUE must be a
765 : valid font name or font object. Setting this attribute will also
766 : set the `:family', `:foundry', `:width', `:height', `:weight',
767 : and `:slant' attributes.
768 :
769 : `:inherit'
770 :
771 : VALUE is the name of a face from which to inherit attributes, or
772 : a list of face names. Attributes from inherited faces are merged
773 : into the face like an underlying face would be, with higher
774 : priority than underlying faces.
775 :
776 : For backward compatibility, the keywords `:bold' and `:italic'
777 : can be used to specify weight and slant respectively. This usage
778 : is considered obsolete. For these two keywords, the VALUE must
779 : be either t or nil. A value of t for `:bold' is equivalent to
780 : setting `:weight' to `bold', and a value of t for `:italic' is
781 : equivalent to setting `:slant' to `italic'. But if `:weight' is
782 : specified in the face spec, `:bold' is ignored, and if `:slant'
783 : is specified, `:italic' is ignored."
784 387 : (setq args (purecopy args))
785 387 : (let ((where (if (null frame) 0 frame))
786 387 : (spec args)
787 : family foundry orig-family orig-foundry)
788 : ;; If we set the new-frame defaults, this face is modified outside Custom.
789 387 : (if (memq where '(0 t))
790 387 : (put (or (get face 'face-alias) face) 'face-modified t))
791 : ;; If family and/or foundry are specified, set it first. Certain
792 : ;; face attributes, e.g. :weight semi-condensed, are not supported
793 : ;; in every font. See bug#1127.
794 2456 : (while spec
795 2069 : (cond ((eq (car spec) :family)
796 132 : (setq family (cadr spec)))
797 1937 : ((eq (car spec) :foundry)
798 2069 : (setq foundry (cadr spec))))
799 2069 : (setq spec (cddr spec)))
800 387 : (when (or family foundry)
801 132 : (when (and (stringp family)
802 132 : (string-match "\\([^-]*\\)-\\([^-]*\\)" family))
803 0 : (setq orig-foundry foundry
804 0 : orig-family family)
805 0 : (unless foundry
806 0 : (setq foundry (match-string 1 family)))
807 0 : (setq family (match-string 2 family))
808 : ;; Reject bogus "families" that are all-digits -- those are some
809 : ;; weird font names, like Foobar-12, that end in a number.
810 0 : (when (string-match "\\`[0-9]*\\'" family)
811 0 : (setq family orig-family)
812 132 : (setq foundry orig-foundry)))
813 132 : (when (or (stringp family) (eq family 'unspecified))
814 132 : (internal-set-lisp-face-attribute face :family (purecopy family)
815 132 : where))
816 132 : (when (or (stringp foundry) (eq foundry 'unspecified))
817 129 : (internal-set-lisp-face-attribute face :foundry (purecopy foundry)
818 387 : where)))
819 2456 : (while args
820 2069 : (unless (memq (car args) '(:family :foundry))
821 1808 : (internal-set-lisp-face-attribute face (car args)
822 1808 : (purecopy (cadr args))
823 2069 : where))
824 2069 : (setq args (cddr args)))))
825 :
826 : (defun make-face-bold (face &optional frame _noerror)
827 : "Make the font of FACE be bold, if possible.
828 : FRAME nil or not specified means change face on all frames.
829 : Argument NOERROR is ignored and retained for compatibility.
830 : Use `set-face-attribute' for finer control of the font weight."
831 0 : (interactive (list (read-face-name "Make which face bold"
832 0 : (face-at-point t))))
833 0 : (set-face-attribute face frame :weight 'bold))
834 :
835 :
836 : (defun make-face-unbold (face &optional frame _noerror)
837 : "Make the font of FACE be non-bold, if possible.
838 : FRAME nil or not specified means change face on all frames.
839 : Argument NOERROR is ignored and retained for compatibility."
840 0 : (interactive (list (read-face-name "Make which face non-bold"
841 0 : (face-at-point t))))
842 0 : (set-face-attribute face frame :weight 'normal))
843 :
844 :
845 : (defun make-face-italic (face &optional frame _noerror)
846 : "Make the font of FACE be italic, if possible.
847 : FRAME nil or not specified means change face on all frames.
848 : Argument NOERROR is ignored and retained for compatibility.
849 : Use `set-face-attribute' for finer control of the font slant."
850 0 : (interactive (list (read-face-name "Make which face italic"
851 0 : (face-at-point t))))
852 0 : (set-face-attribute face frame :slant 'italic))
853 :
854 :
855 : (defun make-face-unitalic (face &optional frame _noerror)
856 : "Make the font of FACE be non-italic, if possible.
857 : FRAME nil or not specified means change face on all frames.
858 : Argument NOERROR is ignored and retained for compatibility."
859 0 : (interactive (list (read-face-name "Make which face non-italic"
860 0 : (face-at-point t))))
861 0 : (set-face-attribute face frame :slant 'normal))
862 :
863 :
864 : (defun make-face-bold-italic (face &optional frame _noerror)
865 : "Make the font of FACE be bold and italic, if possible.
866 : FRAME nil or not specified means change face on all frames.
867 : Argument NOERROR is ignored and retained for compatibility.
868 : Use `set-face-attribute' for finer control of font weight and slant."
869 0 : (interactive (list (read-face-name "Make which face bold-italic"
870 0 : (face-at-point t))))
871 0 : (set-face-attribute face frame :weight 'bold :slant 'italic))
872 :
873 :
874 : (defun set-face-font (face font &optional frame)
875 : "Change font-related attributes of FACE to those of FONT (a string).
876 : FRAME nil or not specified means change face on all frames.
877 : This sets the attributes `:family', `:foundry', `:width',
878 : `:height', `:weight', and `:slant'. When called interactively,
879 : prompt for the face and font."
880 0 : (interactive (read-face-and-attribute :font))
881 0 : (set-face-attribute face frame :font font))
882 :
883 :
884 : ;; Implementation note: Emulating gray background colors with a
885 : ;; stipple pattern is now part of the face realization process, and is
886 : ;; done in C depending on the frame on which the face is realized.
887 :
888 : (defun set-face-background (face color &optional frame)
889 : "Change the background color of face FACE to COLOR (a string).
890 : FRAME nil or not specified means change face on all frames.
891 : COLOR can be a system-defined color name (see `list-colors-display')
892 : or a hex spec of the form #RRGGBB.
893 : When called interactively, prompts for the face and color."
894 0 : (interactive (read-face-and-attribute :background))
895 0 : (set-face-attribute face frame :background (or color 'unspecified)))
896 :
897 :
898 : (defun set-face-foreground (face color &optional frame)
899 : "Change the foreground color of face FACE to COLOR (a string).
900 : FRAME nil or not specified means change face on all frames.
901 : COLOR can be a system-defined color name (see `list-colors-display')
902 : or a hex spec of the form #RRGGBB.
903 : When called interactively, prompts for the face and color."
904 0 : (interactive (read-face-and-attribute :foreground))
905 0 : (set-face-attribute face frame :foreground (or color 'unspecified)))
906 :
907 :
908 : (defun set-face-stipple (face stipple &optional frame)
909 : "Change the stipple pixmap of face FACE to STIPPLE.
910 : FRAME nil or not specified means change face on all frames.
911 : STIPPLE should be a string, the name of a file of pixmap data.
912 : The directories listed in the `x-bitmap-file-path' variable are searched.
913 :
914 : Alternatively, STIPPLE may be a list of the form (WIDTH HEIGHT DATA)
915 : where WIDTH and HEIGHT are the size in pixels,
916 : and DATA is a string, containing the raw bits of the bitmap."
917 0 : (interactive (read-face-and-attribute :stipple))
918 0 : (set-face-attribute face frame :stipple (or stipple 'unspecified)))
919 :
920 :
921 : (defun set-face-underline (face underline &optional frame)
922 : "Specify whether face FACE is underlined.
923 : UNDERLINE nil means FACE explicitly doesn't underline.
924 : UNDERLINE t means FACE underlines with its foreground color.
925 : If UNDERLINE is a string, underline with that color.
926 :
927 : UNDERLINE may also be a list of the form (:color COLOR :style STYLE),
928 : where COLOR is a string or `foreground-color', and STYLE is either
929 : `line' or `wave'. :color may be omitted, which means to use the
930 : foreground color. :style may be omitted, which means to use a line.
931 :
932 : FRAME nil or not specified means change face on all frames.
933 : Use `set-face-attribute' to \"unspecify\" underlining."
934 0 : (interactive (read-face-and-attribute :underline))
935 0 : (set-face-attribute face frame :underline underline))
936 :
937 : (define-obsolete-function-alias 'set-face-underline-p
938 : 'set-face-underline "24.3")
939 :
940 :
941 : (defun set-face-inverse-video (face inverse-video-p &optional frame)
942 : "Specify whether face FACE is in inverse video.
943 : INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video.
944 : INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video.
945 : FRAME nil or not specified means change face on all frames.
946 : Use `set-face-attribute' to \"unspecify\" the inverse video attribute."
947 : (interactive
948 0 : (let ((list (read-face-and-attribute :inverse-video)))
949 0 : (list (car list) (if (cadr list) t))))
950 0 : (set-face-attribute face frame :inverse-video inverse-video-p))
951 :
952 : (define-obsolete-function-alias 'set-face-inverse-video-p
953 : 'set-face-inverse-video "24.4")
954 :
955 : (defun set-face-bold (face bold-p &optional frame)
956 : "Specify whether face FACE is bold.
957 : BOLD-P non-nil means FACE should explicitly display bold.
958 : BOLD-P nil means FACE should explicitly display non-bold.
959 : FRAME nil or not specified means change face on all frames.
960 : Use `set-face-attribute' or `modify-face' for finer control."
961 0 : (if (null bold-p)
962 0 : (make-face-unbold face frame)
963 0 : (make-face-bold face frame)))
964 :
965 : (define-obsolete-function-alias 'set-face-bold-p 'set-face-bold "24.4")
966 :
967 :
968 : (defun set-face-italic (face italic-p &optional frame)
969 : "Specify whether face FACE is italic.
970 : ITALIC-P non-nil means FACE should explicitly display italic.
971 : ITALIC-P nil means FACE should explicitly display non-italic.
972 : FRAME nil or not specified means change face on all frames.
973 : Use `set-face-attribute' or `modify-face' for finer control."
974 0 : (if (null italic-p)
975 0 : (make-face-unitalic face frame)
976 0 : (make-face-italic face frame)))
977 :
978 : (define-obsolete-function-alias 'set-face-italic-p 'set-face-italic "24.4")
979 :
980 :
981 : (defalias 'set-face-background-pixmap 'set-face-stipple)
982 :
983 :
984 : (defun invert-face (face &optional frame)
985 : "Swap the foreground and background colors of FACE.
986 : If FRAME is omitted or nil, it means change face on all frames.
987 : If FACE specifies neither foreground nor background color,
988 : set its foreground and background to the background and foreground
989 : of the default face. Value is FACE."
990 0 : (interactive (list (read-face-name "Invert face" (face-at-point t))))
991 0 : (let ((fg (face-attribute face :foreground frame))
992 0 : (bg (face-attribute face :background frame)))
993 0 : (if (not (and (eq fg 'unspecified) (eq bg 'unspecified)))
994 0 : (set-face-attribute face frame :foreground bg :background fg)
995 0 : (set-face-attribute face frame
996 : :foreground
997 0 : (face-attribute 'default :background frame)
998 : :background
999 0 : (face-attribute 'default :foreground frame))))
1000 0 : face)
1001 :
1002 :
1003 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1004 : ;;; Interactively modifying faces.
1005 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1006 :
1007 : (defvar crm-separator) ; from crm.el
1008 :
1009 : (defun read-face-name (prompt &optional default multiple)
1010 : "Read one or more face names, prompting with PROMPT.
1011 : PROMPT should not end in a space or a colon.
1012 :
1013 : If DEFAULT is non-nil, it should be a face (a symbol) or a face
1014 : name (a string). It can also be a list of faces or face names.
1015 :
1016 : If MULTIPLE is non-nil, the return value from this function is a
1017 : list of faces. Otherwise a single face is returned.
1018 :
1019 : If the user enter the empty string at the prompt, DEFAULT is
1020 : returned after a possible transformation according to MULTIPLE.
1021 : That is, if DEFAULT is a list and MULTIPLE is nil, the first
1022 : element of DEFAULT is returned. If DEFAULT isn't a list, but
1023 : MULTIPLE is non-nil, a one-element list containing DEFAULT is
1024 : returned. Otherwise, DEFAULT is returned verbatim."
1025 0 : (unless (listp default)
1026 0 : (setq default (list default)))
1027 0 : (when default
1028 0 : (setq default
1029 0 : (if multiple
1030 0 : (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
1031 0 : default ", ")
1032 : ;; If we only want one, and the default is more than one,
1033 : ;; discard the unwanted ones.
1034 0 : (setq default (car default))
1035 0 : (if (symbolp default)
1036 0 : (symbol-name default)
1037 0 : default))))
1038 0 : (when (and default (not multiple))
1039 0 : (require 'crm)
1040 : ;; For compatibility with `completing-read-multiple' use `crm-separator'
1041 : ;; to define DEFAULT if MULTIPLE is nil.
1042 0 : (setq default (car (split-string default crm-separator t))))
1043 :
1044 : ;; Older versions of `read-face-name' did not append ": " to the
1045 : ;; prompt, so there are third party libraries that have that in the
1046 : ;; prompt. If so, remove it.
1047 0 : (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt))
1048 0 : (let ((prompt (if default
1049 0 : (format-message "%s (default `%s'): " prompt default)
1050 0 : (format "%s: " prompt)))
1051 : aliasfaces nonaliasfaces faces)
1052 : ;; Build up the completion tables.
1053 0 : (mapatoms (lambda (s)
1054 0 : (if (facep s)
1055 0 : (if (get s 'face-alias)
1056 0 : (push (symbol-name s) aliasfaces)
1057 0 : (push (symbol-name s) nonaliasfaces)))))
1058 0 : (if multiple
1059 0 : (progn
1060 0 : (dolist (face (completing-read-multiple
1061 0 : prompt
1062 0 : (completion-table-in-turn nonaliasfaces aliasfaces)
1063 0 : nil t nil 'face-name-history default))
1064 : ;; Ignore elements that are not faces
1065 : ;; (for example, because DEFAULT was "all faces")
1066 0 : (if (facep face) (push (intern face) faces)))
1067 0 : (nreverse faces))
1068 0 : (let ((face (completing-read
1069 0 : prompt
1070 0 : (completion-table-in-turn nonaliasfaces aliasfaces)
1071 0 : nil t nil 'face-name-history default)))
1072 0 : (if (facep face) (intern face))))))
1073 :
1074 : ;; Not defined without X, but behind window-system test.
1075 : (defvar x-bitmap-file-path)
1076 :
1077 : (defun face-valid-attribute-values (attribute &optional frame)
1078 : "Return valid values for face attribute ATTRIBUTE.
1079 : The optional argument FRAME is used to determine available fonts
1080 : and colors. If it is nil or not specified, the selected frame is used.
1081 : Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value out
1082 : of a set of discrete values. Value is `integerp' if ATTRIBUTE expects
1083 : an integer value."
1084 0 : (let ((valid
1085 0 : (pcase attribute
1086 : (`:family
1087 0 : (if (window-system frame)
1088 0 : (mapcar (lambda (x) (cons x x))
1089 0 : (font-family-list))
1090 : ;; Only one font on TTYs.
1091 0 : (list (cons "default" "default"))))
1092 : (`:foundry
1093 0 : (list nil))
1094 : (`:width
1095 0 : (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
1096 0 : font-width-table))
1097 : (`:weight
1098 0 : (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
1099 0 : font-weight-table))
1100 : (`:slant
1101 0 : (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
1102 0 : font-slant-table))
1103 : (`:inverse-video
1104 0 : (mapcar #'(lambda (x) (cons (symbol-name x) x))
1105 0 : (internal-lisp-face-attribute-values attribute)))
1106 : ((or `:underline `:overline `:strike-through `:box)
1107 0 : (if (window-system frame)
1108 0 : (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x))
1109 0 : (internal-lisp-face-attribute-values attribute))
1110 0 : (mapcar #'(lambda (c) (cons c c))
1111 0 : (defined-colors frame)))
1112 0 : (mapcar #'(lambda (x) (cons (symbol-name x) x))
1113 0 : (internal-lisp-face-attribute-values attribute))))
1114 : ((or `:foreground `:background)
1115 0 : (mapcar #'(lambda (c) (cons c c))
1116 0 : (defined-colors frame)))
1117 : (`:height
1118 : 'integerp)
1119 : (`:stipple
1120 0 : (and (memq (window-system frame) '(x ns)) ; No stipple on w32
1121 0 : (mapcar #'list
1122 0 : (apply #'nconc
1123 0 : (mapcar (lambda (dir)
1124 0 : (and (file-readable-p dir)
1125 0 : (file-directory-p dir)
1126 0 : (directory-files dir)))
1127 0 : x-bitmap-file-path)))))
1128 : (`:inherit
1129 0 : (cons '("none" . nil)
1130 0 : (mapcar #'(lambda (c) (cons (symbol-name c) c))
1131 0 : (face-list))))
1132 : (_
1133 0 : (error "Internal error")))))
1134 0 : (if (and (listp valid) (not (memq attribute '(:inherit))))
1135 0 : (nconc (list (cons "unspecified" 'unspecified)) valid)
1136 0 : valid)))
1137 :
1138 :
1139 : (defconst face-attribute-name-alist
1140 : '((:family . "font family")
1141 : (:foundry . "font foundry")
1142 : (:width . "character set width")
1143 : (:height . "height in 1/10 pt")
1144 : (:weight . "weight")
1145 : (:slant . "slant")
1146 : (:underline . "underline")
1147 : (:overline . "overline")
1148 : (:strike-through . "strike-through")
1149 : (:box . "box")
1150 : (:inverse-video . "inverse-video display")
1151 : (:foreground . "foreground color")
1152 : (:background . "background color")
1153 : (:stipple . "background stipple")
1154 : (:inherit . "inheritance"))
1155 : "An alist of descriptive names for face attributes.
1156 : Each element has the form (ATTRIBUTE-NAME . DESCRIPTION) where
1157 : ATTRIBUTE-NAME is a face attribute name (a keyword symbol), and
1158 : DESCRIPTION is a descriptive name for ATTRIBUTE-NAME.")
1159 :
1160 :
1161 : (defun face-descriptive-attribute-name (attribute)
1162 : "Return a descriptive name for ATTRIBUTE."
1163 0 : (cdr (assq attribute face-attribute-name-alist)))
1164 :
1165 :
1166 : (defun face-read-string (face default name &optional completion-alist)
1167 : "Interactively read a face attribute string value.
1168 : FACE is the face whose attribute is read. If non-nil, DEFAULT is the
1169 : default string to return if no new value is entered. NAME is a
1170 : descriptive name of the attribute for prompting. COMPLETION-ALIST is an
1171 : alist of valid values, if non-nil.
1172 :
1173 : Entering nothing accepts the default string DEFAULT.
1174 : Value is the new attribute value."
1175 : ;; Capitalize NAME (we don't use `capitalize' because that capitalizes
1176 : ;; each word in a string separately).
1177 0 : (setq name (concat (upcase (substring name 0 1)) (substring name 1)))
1178 0 : (let* ((completion-ignore-case t)
1179 0 : (value (completing-read
1180 0 : (format-message (if default
1181 : "%s for face `%s' (default %s): "
1182 0 : "%s for face `%s': ")
1183 0 : name face default)
1184 0 : completion-alist nil nil nil nil default)))
1185 0 : (if (equal value "") default value)))
1186 :
1187 :
1188 : (defun face-read-integer (face default name)
1189 : "Interactively read an integer face attribute value.
1190 : FACE is the face whose attribute is read. DEFAULT is the default
1191 : value to return if no new value is entered. NAME is a descriptive
1192 : name of the attribute for prompting. Value is the new attribute value."
1193 0 : (let ((new-value
1194 0 : (face-read-string face
1195 0 : (format "%s" default)
1196 0 : name
1197 0 : (list (cons "unspecified" 'unspecified)))))
1198 0 : (cond ((equal new-value "unspecified")
1199 : 'unspecified)
1200 0 : ((member new-value '("unspecified-fg" "unspecified-bg"))
1201 0 : new-value)
1202 : (t
1203 0 : (string-to-number new-value)))))
1204 :
1205 :
1206 : ;; FIXME this does allow you to enter the list forms of :box,
1207 : ;; :stipple, or :underline, because face-valid-attribute-values does
1208 : ;; not return those forms.
1209 : (defun read-face-attribute (face attribute &optional frame)
1210 : "Interactively read a new value for FACE's ATTRIBUTE.
1211 : Optional argument FRAME nil or unspecified means read an attribute value
1212 : of a global face. Value is the new attribute value."
1213 0 : (let* ((old-value (face-attribute face attribute frame))
1214 0 : (attribute-name (face-descriptive-attribute-name attribute))
1215 0 : (valid (face-valid-attribute-values attribute frame))
1216 : new-value)
1217 : ;; Represent complex attribute values as strings by printing them
1218 : ;; out. Stipple can be a vector; (WIDTH HEIGHT DATA). Box can be
1219 : ;; a list `(:width WIDTH :color COLOR)' or `(:width WIDTH :shadow
1220 : ;; SHADOW)'. Underline can be `(:color COLOR :style STYLE)'.
1221 0 : (and (memq attribute '(:box :stipple :underline))
1222 0 : (or (consp old-value)
1223 0 : (vectorp old-value))
1224 0 : (setq old-value (prin1-to-string old-value)))
1225 0 : (cond ((listp valid)
1226 0 : (let ((default
1227 0 : (or (car (rassoc old-value valid))
1228 0 : (format "%s" old-value))))
1229 0 : (setq new-value
1230 0 : (face-read-string face default attribute-name valid))
1231 0 : (if (equal new-value default)
1232 : ;; Nothing changed, so don't bother with all the stuff
1233 : ;; below. In particular, this avoids a non-tty color
1234 : ;; from being canonicalized for a tty when the user
1235 : ;; just uses the default.
1236 0 : (setq new-value old-value)
1237 : ;; Terminal frames can support colors that don't appear
1238 : ;; explicitly in VALID, using color approximation code
1239 : ;; in tty-colors.el.
1240 0 : (when (and (memq attribute '(:foreground :background))
1241 0 : (not (memq (window-system frame) '(x w32 ns)))
1242 0 : (not (member new-value
1243 : '("unspecified"
1244 0 : "unspecified-fg" "unspecified-bg"))))
1245 0 : (setq new-value (car (tty-color-desc new-value frame))))
1246 0 : (when (assoc new-value valid)
1247 0 : (setq new-value (cdr (assoc new-value valid)))))))
1248 0 : ((eq valid 'integerp)
1249 0 : (setq new-value (face-read-integer face old-value attribute-name)))
1250 0 : (t (error "Internal error")))
1251 : ;; Convert stipple and box value text we read back to a list or
1252 : ;; vector if it looks like one. This makes the assumption that a
1253 : ;; pixmap file name won't start with an open-paren.
1254 0 : (and (memq attribute '(:stipple :box :underline))
1255 0 : (stringp new-value)
1256 0 : (string-match-p "^[[(]" new-value)
1257 0 : (setq new-value (read new-value)))
1258 0 : new-value))
1259 :
1260 : (declare-function fontset-list "fontset.c" ())
1261 : (declare-function x-list-fonts "xfaces.c"
1262 : (pattern &optional face frame maximum width))
1263 :
1264 : (defun read-face-font (face &optional frame)
1265 : "Read the name of a font for FACE on FRAME.
1266 : If optional argument FRAME is nil or omitted, use the selected frame."
1267 0 : (let ((completion-ignore-case t))
1268 0 : (completing-read (format-message
1269 0 : "Set font attributes of face `%s' from font: " face)
1270 0 : (append (fontset-list) (x-list-fonts "*" nil frame)))))
1271 :
1272 :
1273 : (defun read-all-face-attributes (face &optional frame)
1274 : "Interactively read all attributes for FACE.
1275 : If optional argument FRAME is nil or omitted, use the selected frame.
1276 : Value is a property list of attribute names and new values."
1277 0 : (let (result)
1278 0 : (dolist (attribute face-attribute-name-alist result)
1279 0 : (setq result (cons (car attribute)
1280 0 : (cons (read-face-attribute face (car attribute) frame)
1281 0 : result))))))
1282 :
1283 : (defun modify-face (&optional face foreground background stipple
1284 : bold-p italic-p underline inverse-p frame)
1285 : "Modify attributes of faces interactively.
1286 : If optional argument FRAME is nil or omitted, modify the face used
1287 : for newly created frame, i.e. the global face.
1288 : For non-interactive use, `set-face-attribute' is preferred.
1289 : When called from Lisp, if FACE is nil, all arguments but FRAME are ignored
1290 : and the face and its settings are obtained by querying the user."
1291 : (interactive)
1292 0 : (if face
1293 0 : (set-face-attribute face frame
1294 0 : :foreground (or foreground 'unspecified)
1295 0 : :background (or background 'unspecified)
1296 0 : :stipple stipple
1297 0 : :weight (if bold-p 'bold 'normal)
1298 0 : :slant (if italic-p 'italic 'normal)
1299 0 : :underline underline
1300 0 : :inverse-video inverse-p)
1301 0 : (setq face (read-face-name "Modify face" (face-at-point t)))
1302 0 : (apply #'set-face-attribute face frame
1303 0 : (read-all-face-attributes face frame))))
1304 :
1305 : (defun read-face-and-attribute (attribute &optional frame)
1306 : "Read face name and face attribute value.
1307 : ATTRIBUTE is the attribute whose new value is read.
1308 : FRAME nil or unspecified means read attribute value of global face.
1309 : Value is a list (FACE NEW-VALUE) where FACE is the face read
1310 : \(a symbol), and NEW-VALUE is value read."
1311 0 : (cond ((eq attribute :font)
1312 0 : (let* ((prompt "Set font-related attributes of face")
1313 0 : (face (read-face-name prompt (face-at-point t)))
1314 0 : (font (read-face-font face frame)))
1315 0 : (list face font)))
1316 : (t
1317 0 : (let* ((attribute-name (face-descriptive-attribute-name attribute))
1318 0 : (prompt (format "Set %s of face" attribute-name))
1319 0 : (face (read-face-name prompt (face-at-point t)))
1320 0 : (new-value (read-face-attribute face attribute frame)))
1321 0 : (list face new-value)))))
1322 :
1323 :
1324 :
1325 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1326 : ;;; Listing faces.
1327 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1328 :
1329 : (defconst list-faces-sample-text
1330 : "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
1331 : "Text string to display as the sample text for `list-faces-display'.")
1332 :
1333 :
1334 : ;; The name list-faces would be more consistent, but let's avoid a
1335 : ;; conflict with Lucid, which uses that name differently.
1336 :
1337 : (defvar help-xref-stack)
1338 : (defun list-faces-display (&optional regexp)
1339 : "List all faces, using the same sample text in each.
1340 : The sample text is a string that comes from the variable
1341 : `list-faces-sample-text'.
1342 :
1343 : If REGEXP is non-nil, list only those faces with names matching
1344 : this regular expression. When called interactively with a prefix
1345 : argument, prompt for a regular expression using `read-regexp'."
1346 0 : (interactive (list (and current-prefix-arg
1347 0 : (read-regexp "List faces matching regexp"))))
1348 0 : (let ((all-faces (zerop (length regexp)))
1349 0 : (frame (selected-frame))
1350 : (max-length 0)
1351 : faces line-format
1352 : disp-frame window face-name)
1353 : ;; We filter and take the max length in one pass
1354 0 : (setq faces
1355 0 : (delq nil
1356 0 : (mapcar (lambda (f)
1357 0 : (let ((s (symbol-name f)))
1358 0 : (when (or all-faces (string-match-p regexp s))
1359 0 : (setq max-length (max (length s) max-length))
1360 0 : f)))
1361 0 : (sort (face-list) #'string-lessp))))
1362 0 : (unless faces
1363 0 : (error "No faces matching \"%s\"" regexp))
1364 0 : (setq max-length (1+ max-length)
1365 0 : line-format (format "%%-%ds" max-length))
1366 0 : (with-help-window "*Faces*"
1367 0 : (with-current-buffer standard-output
1368 0 : (setq truncate-lines t)
1369 0 : (insert
1370 0 : (substitute-command-keys
1371 0 : (concat
1372 : "\\<help-mode-map>Use "
1373 0 : (if (display-mouse-p) "\\[help-follow-mouse] or ")
1374 : "\\[help-follow] on a face name to customize it\n"
1375 0 : "or on its sample text for a description of the face.\n\n")))
1376 0 : (setq help-xref-stack nil)
1377 0 : (dolist (face faces)
1378 0 : (setq face-name (symbol-name face))
1379 0 : (insert (format line-format face-name))
1380 : ;; Hyperlink to a customization buffer for the face. Using
1381 : ;; the help xref mechanism may not be the best way.
1382 0 : (save-excursion
1383 0 : (save-match-data
1384 0 : (search-backward face-name)
1385 0 : (setq help-xref-stack-item `(list-faces-display ,regexp))
1386 0 : (help-xref-button 0 'help-customize-face face)))
1387 0 : (let ((beg (point))
1388 0 : (line-beg (line-beginning-position)))
1389 0 : (insert list-faces-sample-text)
1390 : ;; Hyperlink to a help buffer for the face.
1391 0 : (save-excursion
1392 0 : (save-match-data
1393 0 : (search-backward list-faces-sample-text)
1394 0 : (help-xref-button 0 'help-face face)))
1395 0 : (insert "\n")
1396 0 : (put-text-property beg (1- (point)) 'face face)
1397 : ;; Make all face commands default to the proper face
1398 : ;; anywhere in the line.
1399 0 : (put-text-property line-beg (1- (point)) 'read-face-name face)
1400 : ;; If the sample text has multiple lines, line up all of them.
1401 0 : (goto-char beg)
1402 0 : (forward-line 1)
1403 0 : (while (not (eobp))
1404 0 : (insert-char ?\s max-length)
1405 0 : (forward-line 1))))
1406 0 : (goto-char (point-min))))
1407 : ;; If the *Faces* buffer appears in a different frame,
1408 : ;; copy all the face definitions from FRAME,
1409 : ;; so that the display will reflect the frame that was selected.
1410 0 : (setq window (get-buffer-window (get-buffer "*Faces*") t))
1411 0 : (setq disp-frame (if window (window-frame window)
1412 0 : (car (frame-list))))
1413 0 : (or (eq frame disp-frame)
1414 0 : (dolist (face (face-list))
1415 0 : (copy-face face face frame disp-frame)))))
1416 :
1417 :
1418 : (defun describe-face (face &optional frame)
1419 : "Display the properties of face FACE on FRAME.
1420 : Interactively, FACE defaults to the faces of the character after point
1421 : and FRAME defaults to the selected frame.
1422 :
1423 : If the optional argument FRAME is given, report on face FACE in that frame.
1424 : If FRAME is t, report on the defaults for face FACE (for new frames).
1425 : If FRAME is omitted or nil, use the selected frame."
1426 0 : (interactive (list (read-face-name "Describe face"
1427 0 : (or (face-at-point t) 'default)
1428 0 : t)))
1429 0 : (let* ((attrs '((:family . "Family")
1430 : (:foundry . "Foundry")
1431 : (:width . "Width")
1432 : (:height . "Height")
1433 : (:weight . "Weight")
1434 : (:slant . "Slant")
1435 : (:foreground . "Foreground")
1436 : (:distant-foreground . "DistantForeground")
1437 : (:background . "Background")
1438 : (:underline . "Underline")
1439 : (:overline . "Overline")
1440 : (:strike-through . "Strike-through")
1441 : (:box . "Box")
1442 : (:inverse-video . "Inverse")
1443 : (:stipple . "Stipple")
1444 : (:font . "Font")
1445 : (:fontset . "Fontset")
1446 : (:inherit . "Inherit")))
1447 0 : (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
1448 0 : attrs))))
1449 0 : (help-setup-xref (list #'describe-face face)
1450 0 : (called-interactively-p 'interactive))
1451 0 : (unless face
1452 0 : (setq face 'default))
1453 0 : (if (not (listp face))
1454 0 : (setq face (list face)))
1455 0 : (with-help-window (help-buffer)
1456 0 : (with-current-buffer standard-output
1457 0 : (dolist (f face (buffer-string))
1458 0 : (if (stringp f) (setq f (intern f)))
1459 : ;; We may get called for anonymous faces (i.e., faces
1460 : ;; expressed using prop-value plists). Those can't be
1461 : ;; usefully customized, so ignore them.
1462 0 : (when (symbolp f)
1463 0 : (insert "Face: " (symbol-name f))
1464 0 : (if (not (facep f))
1465 0 : (insert " undefined face.\n")
1466 0 : (let ((customize-label "customize this face")
1467 : file-name)
1468 0 : (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
1469 0 : (princ (concat " (" customize-label ")\n"))
1470 : ;; FIXME not sure how much of this belongs here, and
1471 : ;; how much in `face-documentation'. The latter is
1472 : ;; not used much, but needs to return nil for
1473 : ;; undocumented faces.
1474 0 : (let ((alias (get f 'face-alias))
1475 0 : (face f)
1476 : obsolete)
1477 0 : (when alias
1478 0 : (setq face alias)
1479 0 : (insert
1480 0 : (format-message
1481 : "\n %s is an alias for the face `%s'.\n%s"
1482 0 : f alias
1483 0 : (if (setq obsolete (get f 'obsolete-face))
1484 0 : (format-message
1485 : " This face is obsolete%s; use `%s' instead.\n"
1486 0 : (if (stringp obsolete)
1487 0 : (format " since %s" obsolete)
1488 0 : "")
1489 0 : alias)
1490 0 : ""))))
1491 0 : (insert "\nDocumentation:\n"
1492 0 : (substitute-command-keys
1493 0 : (or (face-documentation face)
1494 0 : "Not documented as a face."))
1495 0 : "\n\n"))
1496 0 : (with-current-buffer standard-output
1497 0 : (save-excursion
1498 0 : (re-search-backward
1499 0 : (concat "\\(" customize-label "\\)") nil t)
1500 0 : (help-xref-button 1 'help-customize-face f)))
1501 0 : (setq file-name (find-lisp-object-file-name f 'defface))
1502 0 : (when file-name
1503 0 : (princ (substitute-command-keys "Defined in `"))
1504 0 : (princ (file-name-nondirectory file-name))
1505 0 : (princ (substitute-command-keys "'"))
1506 : ;; Make a hyperlink to the library.
1507 0 : (save-excursion
1508 0 : (re-search-backward
1509 0 : (substitute-command-keys "`\\([^`']+\\)'") nil t)
1510 0 : (help-xref-button 1 'help-face-def f file-name))
1511 0 : (princ ".")
1512 0 : (terpri)
1513 0 : (terpri))
1514 0 : (dolist (a attrs)
1515 0 : (let ((attr (face-attribute f (car a) frame)))
1516 0 : (insert (make-string (- max-width (length (cdr a))) ?\s)
1517 0 : (cdr a) ": " (format "%s" attr))
1518 0 : (if (and (eq (car a) :inherit)
1519 0 : (not (eq attr 'unspecified)))
1520 : ;; Make a hyperlink to the parent face.
1521 0 : (save-excursion
1522 0 : (re-search-backward ": \\([^:]+\\)" nil t)
1523 0 : (help-xref-button 1 'help-face attr)))
1524 0 : (insert "\n")))))
1525 0 : (terpri)))))))
1526 :
1527 :
1528 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1529 : ;;; Face specifications (defface).
1530 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1531 :
1532 : ;; Parameter FRAME Is kept for call compatibility to with previous
1533 : ;; face implementation.
1534 :
1535 : (defun face-attr-construct (face &optional _frame)
1536 : "Return a `defface'-style attribute list for FACE.
1537 : Value is a property list of pairs ATTRIBUTE VALUE for all specified
1538 : face attributes of FACE where ATTRIBUTE is the attribute name and
1539 : VALUE is the specified value of that attribute.
1540 : Argument FRAME is ignored and retained for compatibility."
1541 0 : (let (result)
1542 0 : (dolist (entry face-attribute-name-alist result)
1543 0 : (let* ((attribute (car entry))
1544 0 : (value (face-attribute face attribute)))
1545 0 : (unless (eq value 'unspecified)
1546 0 : (setq result (nconc (list attribute value) result)))))))
1547 :
1548 :
1549 : (defun face-spec-set-match-display (display frame)
1550 : "Non-nil if DISPLAY matches FRAME.
1551 : DISPLAY is part of a spec such as can be used in `defface'.
1552 : If FRAME is nil, the current FRAME is used."
1553 547 : (let* ((conjuncts display)
1554 : conjunct req options
1555 : ;; t means we have succeeded against all the conjuncts in
1556 : ;; DISPLAY that have been tested so far.
1557 : (match t))
1558 547 : (if (eq conjuncts t)
1559 547 : (setq conjuncts nil))
1560 902 : (while (and conjuncts match)
1561 355 : (setq conjunct (car conjuncts)
1562 355 : conjuncts (cdr conjuncts)
1563 355 : req (car conjunct)
1564 355 : options (cdr conjunct)
1565 355 : match (cond ((eq req 'type)
1566 24 : (or (memq (window-system frame) options)
1567 24 : (and (memq 'graphic options)
1568 24 : (memq (window-system frame) '(x w32 ns)))
1569 : ;; FIXME: This should be revisited to use
1570 : ;; display-graphic-p, provided that the
1571 : ;; color selection depends on the number
1572 : ;; of supported colors, and all defface's
1573 : ;; are changed to look at number of colors
1574 : ;; instead of (type graphic) etc.
1575 24 : (if (null (window-system frame))
1576 24 : (memq 'tty options)
1577 0 : (or (and (memq 'motif options)
1578 0 : (featurep 'motif))
1579 0 : (and (memq 'gtk options)
1580 0 : (featurep 'gtk))
1581 0 : (and (memq 'lucid options)
1582 0 : (featurep 'x-toolkit)
1583 0 : (not (featurep 'motif))
1584 0 : (not (featurep 'gtk)))
1585 0 : (and (memq 'x-toolkit options)
1586 24 : (featurep 'x-toolkit))))))
1587 331 : ((eq req 'min-colors)
1588 1 : (>= (display-color-cells frame) (car options)))
1589 330 : ((eq req 'class)
1590 306 : (memq (frame-parameter frame 'display-type) options))
1591 24 : ((eq req 'background)
1592 16 : (memq (frame-parameter frame 'background-mode)
1593 16 : options))
1594 8 : ((eq req 'supports)
1595 8 : (display-supports-face-attributes-p options frame))
1596 0 : (t (error "Unknown req `%S' with options `%S'"
1597 547 : req options)))))
1598 547 : match))
1599 :
1600 :
1601 : (defun face-spec-choose (spec &optional frame no-match-retval)
1602 : "Return the proper attributes for FRAME, out of SPEC.
1603 :
1604 : Value is a plist of face attributes in the form of attribute-value pairs.
1605 : If no match is found or SPEC is nil, return nil, unless NO-MATCH-RETVAL
1606 : is given, in which case return its value instead."
1607 386 : (unless frame
1608 386 : (setq frame (selected-frame)))
1609 386 : (let ((tail spec)
1610 : result defaults match-found)
1611 979 : (while tail
1612 1186 : (let* ((entry (pop tail))
1613 593 : (display (car entry))
1614 593 : (attrs (cdr entry))
1615 : thisval)
1616 : ;; Get the attributes as actually specified by this alternative.
1617 593 : (setq thisval
1618 593 : (if (null (cdr attrs)) ;; was (listp (car attrs))
1619 : ;; Old-style entry, the attribute list is the
1620 : ;; first element.
1621 103 : (car attrs)
1622 593 : attrs))
1623 :
1624 : ;; If the condition is `default', that sets the default
1625 : ;; for following conditions.
1626 593 : (if (eq display 'default)
1627 46 : (setq defaults thisval)
1628 : ;; Otherwise, if it matches, use it.
1629 547 : (when (face-spec-set-match-display display frame)
1630 212 : (setq result thisval
1631 : tail nil
1632 593 : match-found t)))))
1633 : ;; If defaults have been found, it's safe to just append those to the result
1634 : ;; list (which at this point will be either nil or contain actual specs) and
1635 : ;; return it to the caller. Since there will most definitely be something to
1636 : ;; return in this case, there's no need to know/check if a match was found.
1637 386 : (if defaults
1638 44 : (append result defaults)
1639 342 : (if match-found
1640 204 : result
1641 386 : no-match-retval))))
1642 :
1643 : ;; When over 80 faces get processed at frame creation time, all but
1644 : ;; one specifying all attributes as "unspecified", generating this
1645 : ;; list every time means a lot of consing.
1646 : (defconst face--attributes-unspecified
1647 : (apply 'append
1648 : (mapcar (lambda (x) (list (car x) 'unspecified))
1649 : face-attribute-name-alist)))
1650 :
1651 : (defun face-spec-reset-face (face &optional frame)
1652 : "Reset all attributes of FACE on FRAME to unspecified."
1653 129 : (apply 'set-face-attribute face frame
1654 129 : (if (eq face 'default)
1655 : ;; For the default face, avoid making any attribute
1656 : ;; unspecified. Instead, set attributes to default values
1657 : ;; (see also realize_default_face in xfaces.c).
1658 0 : (append
1659 : '(:underline nil :overline nil :strike-through nil
1660 : :box nil :inverse-video nil :stipple nil :inherit nil)
1661 : ;; `display-graphic-p' is unavailable when running
1662 : ;; temacs, prior to loading frame.el.
1663 0 : (when (fboundp 'display-graphic-p)
1664 0 : (unless (display-graphic-p frame)
1665 0 : `(:family "default" :foundry "default" :width normal
1666 : :height 1 :weight normal :slant normal
1667 0 : :foreground ,(if (frame-parameter nil 'reverse)
1668 : "unspecified-bg"
1669 0 : "unspecified-fg")
1670 0 : :background ,(if (frame-parameter nil 'reverse)
1671 : "unspecified-fg"
1672 0 : "unspecified-bg")))))
1673 : ;; For all other faces, unspecify all attributes.
1674 129 : face--attributes-unspecified)))
1675 :
1676 : (defun face-spec-set (face spec &optional spec-type)
1677 : "Set the FACE's spec SPEC, define FACE, and recalculate its attributes.
1678 : See `defface' for the format of SPEC.
1679 :
1680 : The appearance of each face is controlled by its specs (set via
1681 : this function), and by the internal frame-specific face
1682 : attributes (set via `set-face-attribute').
1683 :
1684 : This function also defines FACE as a valid face name if it is not
1685 : already one, and (re)calculates its attributes on existing
1686 : frames.
1687 :
1688 : The optional argument SPEC-TYPE determines which spec to set:
1689 : nil, omitted or `face-override-spec' means the override spec,
1690 : which overrides all the other types of spec mentioned below
1691 : (this is usually what you want if calling this function
1692 : outside of Custom code);
1693 : `customized-face' or `saved-face' means the customized spec or
1694 : the saved custom spec;
1695 : `face-defface-spec' means the default spec
1696 : (usually set only via `defface');
1697 : `reset' means to ignore SPEC, but clear the `customized-face'
1698 : and `face-override-spec' specs;
1699 : Any other value means not to set any spec, but to run the
1700 : function for defining FACE and recalculating its attributes."
1701 2 : (if (get face 'face-alias)
1702 2 : (setq face (get face 'face-alias)))
1703 : ;; Save SPEC to the relevant symbol property.
1704 2 : (unless spec-type
1705 2 : (setq spec-type 'face-override-spec))
1706 2 : (if (memq spec-type '(face-defface-spec face-override-spec
1707 2 : customized-face saved-face))
1708 2 : (put face spec-type spec))
1709 2 : (if (memq spec-type '(reset saved-face))
1710 2 : (put face 'customized-face nil))
1711 : ;; Setting the face spec via Custom empties out any override spec,
1712 : ;; similar to how setting a variable via Custom changes its values.
1713 2 : (if (memq spec-type '(customized-face saved-face reset))
1714 2 : (put face 'face-override-spec nil))
1715 : ;; If we reset the face based on its custom spec, it is unmodified
1716 : ;; as far as Custom is concerned.
1717 2 : (unless (eq face 'face-override-spec)
1718 2 : (put face 'face-modified nil))
1719 : ;; Initialize the face if it does not exist, then recalculate.
1720 2 : (make-empty-face face)
1721 2 : (dolist (frame (frame-list))
1722 2 : (face-spec-recalc face frame)))
1723 :
1724 : (defun face-spec-recalc (face frame)
1725 : "Reset the face attributes of FACE on FRAME according to its specs.
1726 : The following sources are applied in this order:
1727 :
1728 : face reset to default values if it's the default face, otherwise set
1729 : to unspecified (through `face-spec-reset-face')
1730 : |
1731 : (theme and user customization)
1732 : or: if none of the above exist, and none match the current frame or
1733 : inherited from the defface spec instead of overwriting it
1734 : entirely, the following is applied instead:
1735 : (defface default spec)
1736 : (X resources (if applicable))
1737 : |
1738 : defface override spec"
1739 129 : (while (get face 'face-alias)
1740 129 : (setq face (get face 'face-alias)))
1741 129 : (face-spec-reset-face face frame)
1742 : ;; If FACE is customized or themed, set the custom spec from
1743 : ;; `theme-face' records.
1744 129 : (let ((theme-faces (get face 'theme-face))
1745 : (no-match-found 0)
1746 : face-attrs theme-face-applied)
1747 129 : (if theme-faces
1748 0 : (dolist (elt (reverse theme-faces))
1749 0 : (setq face-attrs (face-spec-choose (cadr elt) frame no-match-found))
1750 0 : (unless (eq face-attrs no-match-found)
1751 0 : (face-spec-set-2 face frame face-attrs)
1752 129 : (setq theme-face-applied t))))
1753 : ;; If there was a spec applicable to FRAME, that overrides the
1754 : ;; defface spec entirely (rather than inheriting from it). If
1755 : ;; there was no spec applicable to FRAME, apply the defface spec
1756 : ;; as well as any applicable X resources.
1757 129 : (unless theme-face-applied
1758 129 : (setq face-attrs (face-spec-choose (face-default-spec face) frame))
1759 129 : (face-spec-set-2 face frame face-attrs)
1760 129 : (make-face-x-resource-internal face frame))
1761 129 : (setq face-attrs (face-spec-choose (get face 'face-override-spec) frame))
1762 129 : (face-spec-set-2 face frame face-attrs)))
1763 :
1764 : (defun face-spec-set-2 (face frame face-attrs)
1765 : "Set the face attributes of FACE on FRAME according to FACE-ATTRS.
1766 : FACE-ATTRS is a plist of face attributes in the form of attribute-value
1767 : pairs."
1768 258 : (let (attrs)
1769 392 : (while face-attrs
1770 134 : (when (assq (car face-attrs) face-x-resources)
1771 268 : (push (car face-attrs) attrs)
1772 268 : (push (cadr face-attrs) attrs))
1773 258 : (setq face-attrs (cddr face-attrs)))
1774 258 : (apply 'set-face-attribute face frame (nreverse attrs))))
1775 :
1776 : (defun face-attr-match-p (face attrs &optional frame)
1777 : "Return t if attributes of FACE match values in plist ATTRS.
1778 : Optional parameter FRAME is the frame whose definition of FACE
1779 : is used. If nil or omitted, use the selected frame."
1780 128 : (unless frame
1781 128 : (setq frame (selected-frame)))
1782 128 : (let* ((list face-attribute-name-alist)
1783 : (match t)
1784 128 : (bold (and (plist-member attrs :bold)
1785 128 : (not (plist-member attrs :weight))))
1786 128 : (italic (and (plist-member attrs :italic)
1787 128 : (not (plist-member attrs :slant))))
1788 128 : (plist (if (or bold italic)
1789 0 : (copy-sequence attrs)
1790 128 : attrs)))
1791 : ;; Handle the Emacs 20 :bold and :italic properties.
1792 128 : (if bold
1793 128 : (plist-put plist :weight (if bold 'bold 'normal)))
1794 128 : (if italic
1795 128 : (plist-put plist :slant (if italic 'italic 'normal)))
1796 2040 : (while (and match list)
1797 1912 : (let* ((attr (caar list))
1798 : (specified-value
1799 1912 : (if (plist-member plist attr)
1800 133 : (plist-get plist attr)
1801 1912 : 'unspecified))
1802 1912 : (value-now (face-attribute face attr frame)))
1803 1912 : (setq match (equal specified-value value-now))
1804 1912 : (setq list (cdr list))))
1805 128 : match))
1806 :
1807 : (defsubst face-spec-match-p (face spec &optional frame)
1808 : "Return t if FACE, on FRAME, matches what SPEC says it should look like."
1809 0 : (face-attr-match-p face (face-spec-choose spec frame) frame))
1810 :
1811 : (defsubst face-default-spec (face)
1812 : "Return the default face-spec for FACE, ignoring any user customization.
1813 : If there is no default for FACE, return nil."
1814 129 : (get face 'face-defface-spec))
1815 :
1816 : (defsubst face-user-default-spec (face)
1817 : "Return the user's customized face-spec for FACE, or the default if none.
1818 : If there is neither a user setting nor a default for FACE, return nil."
1819 0 : (or (get face 'customized-face)
1820 0 : (get face 'saved-face)
1821 0 : (face-default-spec face)))
1822 :
1823 :
1824 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1825 : ;;; Frame-type independent color support.
1826 : ;;; We keep the old x-* names as aliases for back-compatibility.
1827 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1828 :
1829 : (defun defined-colors (&optional frame)
1830 : "Return a list of colors supported for a particular frame.
1831 : The argument FRAME specifies which frame to try.
1832 : The value may be different for frames on different display types.
1833 : If FRAME doesn't support colors, the value is nil.
1834 : If FRAME is nil, that stands for the selected frame."
1835 0 : (if (memq (framep (or frame (selected-frame))) '(x w32 ns))
1836 0 : (xw-defined-colors frame)
1837 0 : (mapcar 'car (tty-color-alist frame))))
1838 : (defalias 'x-defined-colors 'defined-colors)
1839 :
1840 : (defun defined-colors-with-face-attributes (&optional frame)
1841 : "Return a list of colors supported for a particular frame.
1842 : See `defined-colors' for arguments and return value. In contrast
1843 : to `define-colors' the elements of the returned list are color
1844 : strings with text properties, that make the color names render
1845 : with the color they represent as background color."
1846 0 : (mapcar
1847 : (lambda (color-name)
1848 0 : (let ((foreground (readable-foreground-color color-name))
1849 0 : (color (copy-sequence color-name)))
1850 0 : (propertize color 'face (list :foreground foreground
1851 0 : :background color))))
1852 0 : (defined-colors frame)))
1853 :
1854 : (defun readable-foreground-color (color)
1855 : "Return a readable foreground color for background COLOR."
1856 0 : (let* ((rgb (color-values color))
1857 0 : (max (apply #'max rgb))
1858 0 : (black (car (color-values "black")))
1859 0 : (white (car (color-values "white"))))
1860 : ;; Select black or white depending on which one is less similar to
1861 : ;; the brightest component.
1862 0 : (if (> (abs (- max black)) (abs (- max white)))
1863 : "black"
1864 0 : "white")))
1865 :
1866 : (declare-function xw-color-defined-p "xfns.c" (color &optional frame))
1867 :
1868 : (defun color-defined-p (color &optional frame)
1869 : "Return non-nil if COLOR is supported on frame FRAME.
1870 : COLOR should be a string naming a color (e.g. \"white\"), or a
1871 : string specifying a color's RGB components (e.g. \"#ff12ec\"), or
1872 : the symbol `unspecified'.
1873 :
1874 : This function returns nil if COLOR is the symbol `unspecified',
1875 : or one of the strings \"unspecified-fg\" or \"unspecified-bg\".
1876 :
1877 : If FRAME is omitted or nil, use the selected frame."
1878 0 : (unless (member color '(unspecified "unspecified-bg" "unspecified-fg"))
1879 0 : (if (member (framep (or frame (selected-frame))) '(x w32 ns))
1880 0 : (xw-color-defined-p color frame)
1881 0 : (numberp (tty-color-translate color frame)))))
1882 : (defalias 'x-color-defined-p 'color-defined-p)
1883 :
1884 : (declare-function xw-color-values "xfns.c" (color &optional frame))
1885 :
1886 : (defun color-values (color &optional frame)
1887 : "Return a description of the color named COLOR on frame FRAME.
1888 : COLOR should be a string naming a color (e.g. \"white\"), or a
1889 : string specifying a color's RGB components (e.g. \"#ff12ec\").
1890 :
1891 : Return a list of three integers, (RED GREEN BLUE), each between 0
1892 : and either 65280 or 65535 (the maximum depends on the system).
1893 : Use `color-name-to-rgb' if you want RGB floating-point values
1894 : normalized to 1.0.
1895 :
1896 : If FRAME is omitted or nil, use the selected frame.
1897 : If FRAME cannot display COLOR, the value is nil.
1898 :
1899 : COLOR can also be the symbol `unspecified' or one of the strings
1900 : \"unspecified-fg\" or \"unspecified-bg\", in which case the
1901 : return value is nil."
1902 1 : (cond
1903 1 : ((member color '(unspecified "unspecified-fg" "unspecified-bg"))
1904 : nil)
1905 0 : ((memq (framep (or frame (selected-frame))) '(x w32 ns))
1906 0 : (xw-color-values color frame))
1907 : (t
1908 1 : (tty-color-values color frame))))
1909 :
1910 : (defalias 'x-color-values 'color-values)
1911 :
1912 : (declare-function xw-display-color-p "xfns.c" (&optional terminal))
1913 :
1914 : (defun display-color-p (&optional display)
1915 : "Return t if DISPLAY supports color.
1916 : The optional argument DISPLAY specifies which display to ask about.
1917 : DISPLAY should be either a frame or a display name (a string).
1918 : If omitted or nil, that stands for the selected frame's display."
1919 0 : (if (memq (framep-on-display display) '(x w32 ns))
1920 0 : (xw-display-color-p display)
1921 0 : (tty-display-color-p display)))
1922 : (defalias 'x-display-color-p 'display-color-p)
1923 :
1924 : (declare-function x-display-grayscale-p "xfns.c" (&optional terminal))
1925 :
1926 : (defun display-grayscale-p (&optional display)
1927 : "Return non-nil if frames on DISPLAY can display shades of gray.
1928 : DISPLAY should be either a frame or a display name (a string).
1929 : If omitted or nil, that stands for the selected frame's display."
1930 0 : (let ((frame-type (framep-on-display display)))
1931 0 : (cond
1932 0 : ((memq frame-type '(x w32 ns))
1933 0 : (x-display-grayscale-p display))
1934 : (t
1935 0 : (> (tty-color-gray-shades display) 2)))))
1936 :
1937 : (defun read-color (&optional prompt convert-to-RGB allow-empty-name msg)
1938 : "Read a color name or RGB triplet.
1939 : Completion is available for color names, but not for RGB triplets.
1940 :
1941 : RGB triplets have the form \"#RRGGBB\". Each of the R, G, and B
1942 : components can have one to four digits, but all three components
1943 : must have the same number of digits. Each digit is a hex value
1944 : between 0 and F; either upper case or lower case for A through F
1945 : are acceptable.
1946 :
1947 : In addition to standard color names and RGB hex values, the
1948 : following are available as color candidates. In each case, the
1949 : corresponding color is used.
1950 :
1951 : * `foreground at point' - foreground under the cursor
1952 : * `background at point' - background under the cursor
1953 :
1954 : Optional arg PROMPT is the prompt; if nil, use a default prompt.
1955 :
1956 : Interactively, or with optional arg CONVERT-TO-RGB-P non-nil,
1957 : convert an input color name to an RGB hex string. Return the RGB
1958 : hex string.
1959 :
1960 : If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed
1961 : to enter an empty color name (the empty string).
1962 :
1963 : Interactively, or with optional arg MSG non-nil, print the
1964 : resulting color name in the echo area."
1965 : (interactive "i\np\ni\np") ; Always convert to RGB interactively.
1966 0 : (let* ((completion-ignore-case t)
1967 0 : (colors (or facemenu-color-alist
1968 0 : (append '("foreground at point" "background at point")
1969 0 : (if allow-empty-name '(""))
1970 0 : (if (display-color-p)
1971 0 : (defined-colors-with-face-attributes)
1972 0 : (defined-colors)))))
1973 0 : (color (completing-read
1974 0 : (or prompt "Color (name or #RGB triplet): ")
1975 : ;; Completing function for reading colors, accepting
1976 : ;; both color names and RGB triplets.
1977 : (lambda (string pred flag)
1978 0 : (cond
1979 0 : ((null flag) ; Try completion.
1980 0 : (or (try-completion string colors pred)
1981 0 : (if (color-defined-p string)
1982 0 : string)))
1983 0 : ((eq flag t) ; List all completions.
1984 0 : (or (all-completions string colors pred)
1985 0 : (if (color-defined-p string)
1986 0 : (list string))))
1987 0 : ((eq flag 'lambda) ; Test completion.
1988 0 : (or (member string colors)
1989 0 : (color-defined-p string)))))
1990 0 : nil t)))
1991 :
1992 : ;; Process named colors.
1993 0 : (when (member color colors)
1994 0 : (cond ((string-equal color "foreground at point")
1995 0 : (setq color (foreground-color-at-point)))
1996 0 : ((string-equal color "background at point")
1997 0 : (setq color (background-color-at-point))))
1998 0 : (when (and convert-to-RGB
1999 0 : (not (string-equal color "")))
2000 0 : (let ((components (x-color-values color)))
2001 0 : (unless (string-match-p "^#\\(?:[a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
2002 0 : (setq color (format "#%04X%04X%04X"
2003 0 : (logand 65535 (nth 0 components))
2004 0 : (logand 65535 (nth 1 components))
2005 0 : (logand 65535 (nth 2 components))))))))
2006 0 : (when msg (message "Color: `%s'" color))
2007 0 : color))
2008 :
2009 : (defun face-at-point (&optional thing multiple)
2010 : "Return the face of the character after point.
2011 : If it has more than one face, return the first one.
2012 : If THING is non-nil try first to get a face name from the buffer.
2013 : IF MULTIPLE is non-nil, return a list of all faces.
2014 : Return nil if there is no face."
2015 0 : (let (faces)
2016 0 : (if thing
2017 : ;; Try to get a face name from the buffer.
2018 0 : (let ((face (intern-soft (thing-at-point 'symbol))))
2019 0 : (if (facep face)
2020 0 : (push face faces))))
2021 : ;; Add the named faces that the `read-face-name' or `face' property uses.
2022 0 : (let ((faceprop (or (get-char-property (point) 'read-face-name)
2023 0 : (get-char-property (point) 'face))))
2024 0 : (cond ((facep faceprop)
2025 0 : (push faceprop faces))
2026 0 : ((face-list-p faceprop)
2027 0 : (dolist (face faceprop)
2028 0 : (if (facep face)
2029 0 : (push face faces))))))
2030 0 : (if multiple
2031 0 : (delete-dups (nreverse faces))
2032 0 : (car (last faces)))))
2033 :
2034 : (defun faces--attribute-at-point (attribute &optional attribute-unnamed)
2035 : "Return the face ATTRIBUTE at point.
2036 : ATTRIBUTE is a keyword.
2037 : If ATTRIBUTE-UNNAMED is non-nil, it is a symbol to look for in
2038 : unnamed faces (e.g, `foreground-color')."
2039 : ;; `face-at-point' alone is not sufficient. It only gets named faces.
2040 : ;; Need also pick up any face properties that are not associated with named faces.
2041 0 : (let ((faces (or (get-char-property (point) 'read-face-name)
2042 : ;; If `font-lock-mode' is on, `font-lock-face' takes precedence.
2043 0 : (and font-lock-mode
2044 0 : (get-char-property (point) 'font-lock-face))
2045 0 : (get-char-property (point) 'face)))
2046 : (found nil))
2047 0 : (dolist (face (if (face-list-p faces)
2048 0 : faces
2049 0 : (list faces)))
2050 0 : (cond (found)
2051 0 : ((and face (symbolp face))
2052 0 : (let ((value (face-attribute-specified-or
2053 : (face-attribute face attribute nil t)
2054 0 : nil)))
2055 0 : (unless (member value '(nil "unspecified-fg" "unspecified-bg"))
2056 0 : (setq found value))))
2057 0 : ((consp face)
2058 0 : (setq found (cond ((and attribute-unnamed
2059 0 : (memq attribute-unnamed face))
2060 0 : (cdr (memq attribute-unnamed face)))
2061 0 : ((memq attribute face) (cadr (memq attribute face))))))))
2062 0 : (or found
2063 0 : (face-attribute 'default attribute))))
2064 :
2065 : (defun foreground-color-at-point ()
2066 : "Return the foreground color of the character after point."
2067 0 : (faces--attribute-at-point :foreground 'foreground-color))
2068 :
2069 : (defun background-color-at-point ()
2070 : "Return the background color of the character after point."
2071 0 : (faces--attribute-at-point :background 'background-color))
2072 :
2073 :
2074 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2075 : ;;; Frame creation.
2076 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2077 :
2078 : (declare-function x-display-list "xfns.c" ())
2079 : (declare-function x-open-connection "xfns.c"
2080 : (display &optional xrm-string must-succeed))
2081 : (declare-function x-get-resource "frame.c"
2082 : (attribute class &optional component subclass))
2083 : (declare-function x-parse-geometry "frame.c" (string))
2084 : (defvar x-display-name)
2085 :
2086 : (defun x-handle-named-frame-geometry (parameters)
2087 : "Add geometry parameters for a named frame to parameter list PARAMETERS.
2088 : Value is the new parameter list."
2089 : ;; Note that `x-resource-name' has a global meaning.
2090 0 : (let ((x-resource-name (cdr (assq 'name parameters))))
2091 0 : (when x-resource-name
2092 : ;; Before checking X resources, we must have an X connection.
2093 0 : (or (window-system)
2094 0 : (x-display-list)
2095 0 : (x-open-connection (or (cdr (assq 'display parameters))
2096 0 : x-display-name)))
2097 0 : (let (res-geometry parsed)
2098 0 : (and (setq res-geometry (x-get-resource "geometry" "Geometry"))
2099 0 : (setq parsed (x-parse-geometry res-geometry))
2100 0 : (setq parameters
2101 0 : (append parameters parsed
2102 : ;; If the resource specifies a position,
2103 : ;; take note of that.
2104 0 : (if (or (assq 'top parsed) (assq 'left parsed))
2105 0 : '((user-position . t) (user-size . t)))))))))
2106 0 : parameters)
2107 :
2108 :
2109 : (defun x-handle-reverse-video (frame parameters)
2110 : "Handle the reverse-video frame parameter and X resource.
2111 : `x-create-frame' does not handle this one."
2112 0 : (when (cdr (or (assq 'reverse parameters)
2113 0 : (let ((resource (x-get-resource "reverseVideo"
2114 0 : "ReverseVideo")))
2115 0 : (if resource
2116 0 : (cons nil (member (downcase resource)
2117 0 : '("on" "true")))))))
2118 0 : (let* ((params (frame-parameters frame))
2119 0 : (bg (cdr (assq 'foreground-color params)))
2120 0 : (fg (cdr (assq 'background-color params))))
2121 0 : (modify-frame-parameters frame
2122 0 : (list (cons 'foreground-color fg)
2123 0 : (cons 'background-color bg)))
2124 0 : (if (equal bg (cdr (assq 'border-color params)))
2125 0 : (modify-frame-parameters frame
2126 0 : (list (cons 'border-color fg))))
2127 0 : (if (equal bg (cdr (assq 'mouse-color params)))
2128 0 : (modify-frame-parameters frame
2129 0 : (list (cons 'mouse-color fg))))
2130 0 : (if (equal bg (cdr (assq 'cursor-color params)))
2131 0 : (modify-frame-parameters frame
2132 0 : (list (cons 'cursor-color fg)))))))
2133 :
2134 : (declare-function x-create-frame "xfns.c" (parms))
2135 : (declare-function x-setup-function-keys "term/common-win" (frame))
2136 :
2137 : (defun x-create-frame-with-faces (&optional parameters)
2138 : "Create and return a frame with frame parameters PARAMETERS.
2139 : If PARAMETERS specify a frame name, handle X geometry resources
2140 : for that name. If PARAMETERS includes a `reverse' parameter, or
2141 : the X resource \"reverseVideo\" is present, handle that."
2142 0 : (setq parameters (x-handle-named-frame-geometry parameters))
2143 0 : (let* ((params (copy-tree parameters))
2144 0 : (visibility-spec (assq 'visibility parameters))
2145 : (delayed-params '(foreground-color background-color font
2146 : border-color cursor-color mouse-color
2147 : visibility scroll-bar-foreground
2148 : scroll-bar-background))
2149 : frame success)
2150 0 : (dolist (param delayed-params)
2151 0 : (setq params (assq-delete-all param params)))
2152 0 : (setq frame (x-create-frame `((visibility . nil) . ,params)))
2153 0 : (unwind-protect
2154 0 : (progn
2155 0 : (x-setup-function-keys frame)
2156 0 : (x-handle-reverse-video frame parameters)
2157 0 : (frame-set-background-mode frame t)
2158 0 : (face-set-after-frame-default frame parameters)
2159 0 : (if (null visibility-spec)
2160 0 : (make-frame-visible frame)
2161 0 : (modify-frame-parameters frame (list visibility-spec)))
2162 0 : (setq success t))
2163 0 : (unless success
2164 0 : (delete-frame frame)))
2165 0 : frame))
2166 :
2167 : (defun face-set-after-frame-default (frame &optional parameters)
2168 : "Initialize the frame-local faces of FRAME.
2169 : Calculate the face definitions using the face specs, custom theme
2170 : settings, X resources, and `face-new-frame-defaults'.
2171 : Finally, apply any relevant face attributes found amongst the
2172 : frame parameters in PARAMETERS."
2173 : ;; The `reverse' is so that `default' goes first.
2174 0 : (dolist (face (nreverse (face-list)))
2175 0 : (condition-case ()
2176 0 : (progn
2177 : ;; Initialize faces from face spec and custom theme.
2178 0 : (face-spec-recalc face frame)
2179 : ;; Apply attributes specified by face-new-frame-defaults
2180 0 : (internal-merge-in-global-face face frame))
2181 : ;; Don't let invalid specs prevent frame creation.
2182 0 : (error nil)))
2183 :
2184 : ;; Apply attributes specified by frame parameters.
2185 0 : (let ((face-params '((foreground-color default :foreground)
2186 : (background-color default :background)
2187 : (font default :font)
2188 : (border-color border :background)
2189 : (cursor-color cursor :background)
2190 : (scroll-bar-foreground scroll-bar :foreground)
2191 : (scroll-bar-background scroll-bar :background)
2192 : (mouse-color mouse :background))))
2193 0 : (dolist (param face-params)
2194 0 : (let* ((param-name (nth 0 param))
2195 0 : (value (cdr (assq param-name parameters))))
2196 0 : (if value
2197 0 : (set-face-attribute (nth 1 param) frame
2198 0 : (nth 2 param) value))))))
2199 :
2200 : (defun tty-handle-reverse-video (frame parameters)
2201 : "Handle the reverse-video frame parameter for terminal frames."
2202 0 : (when (cdr (assq 'reverse parameters))
2203 0 : (let* ((params (frame-parameters frame))
2204 0 : (bg (cdr (assq 'foreground-color params)))
2205 0 : (fg (cdr (assq 'background-color params))))
2206 0 : (modify-frame-parameters frame
2207 0 : (list (cons 'foreground-color fg)
2208 0 : (cons 'background-color bg)))
2209 0 : (if (equal bg (cdr (assq 'mouse-color params)))
2210 0 : (modify-frame-parameters frame
2211 0 : (list (cons 'mouse-color fg))))
2212 0 : (if (equal bg (cdr (assq 'cursor-color params)))
2213 0 : (modify-frame-parameters frame
2214 0 : (list (cons 'cursor-color fg)))))))
2215 :
2216 :
2217 : (defun tty-create-frame-with-faces (&optional parameters)
2218 : "Create and return a frame from optional frame parameters PARAMETERS.
2219 : If PARAMETERS contains a `reverse' parameter, handle that."
2220 0 : (let ((frame (make-terminal-frame parameters))
2221 : success)
2222 0 : (unwind-protect
2223 0 : (with-selected-frame frame
2224 0 : (tty-handle-reverse-video frame (frame-parameters frame))
2225 :
2226 0 : (unless (terminal-parameter frame 'terminal-initted)
2227 0 : (set-terminal-parameter frame 'terminal-initted t)
2228 0 : (set-locale-environment nil frame)
2229 0 : (tty-run-terminal-initialization frame nil t))
2230 0 : (frame-set-background-mode frame t)
2231 0 : (face-set-after-frame-default frame parameters)
2232 0 : (setq success t))
2233 0 : (unless success
2234 0 : (delete-frame frame)))
2235 0 : frame))
2236 :
2237 : (defun tty-find-type (pred type)
2238 : "Return the longest prefix of TYPE to which PRED returns non-nil.
2239 : TYPE should be a tty type name such as \"xterm-16color\".
2240 :
2241 : The function tries only those prefixes that are followed by a
2242 : dash or underscore in the original type name, like \"xterm\" in
2243 : the above example."
2244 0 : (let (hyphend)
2245 0 : (while (and type
2246 0 : (not (funcall pred type)))
2247 : ;; Strip off last hyphen and what follows, then try again
2248 0 : (setq type
2249 0 : (if (setq hyphend (string-match-p "[-_][^-_]+$" type))
2250 0 : (substring type 0 hyphend)
2251 0 : nil))))
2252 0 : type)
2253 :
2254 : (defvar tty-setup-hook nil
2255 : "Hook run after running the initialization function of a new text terminal.
2256 : Specifically, `tty-run-terminal-initialization' runs this.
2257 : This can be used to fine tune the `input-decode-map', for example.")
2258 :
2259 : (defun tty-run-terminal-initialization (frame &optional type run-hook)
2260 : "Run the special initialization code for the terminal type of FRAME.
2261 : The optional TYPE parameter may be used to override the autodetected
2262 : terminal type to a different value.
2263 :
2264 : This consults `term-file-aliases' to map terminal types to their aliases.
2265 :
2266 : If optional argument RUN-HOOK is non-nil, then as a final step,
2267 : this runs the hook `tty-setup-hook'.
2268 :
2269 : If you set `term-file-prefix' to nil, this function does nothing."
2270 0 : (setq type (or type (tty-type frame)))
2271 0 : (let ((alias (tty-find-type
2272 0 : (lambda (typ) (assoc typ term-file-aliases)) type)))
2273 0 : (if alias (setq type (cdr (assoc alias term-file-aliases)))))
2274 : ;; Load library for our terminal type.
2275 : ;; User init file can set term-file-prefix to nil to prevent this.
2276 0 : (with-selected-frame frame
2277 0 : (unless (null term-file-prefix)
2278 0 : (let* (term-init-func)
2279 : ;; First, load the terminal initialization file, if it is
2280 : ;; available and it hasn't been loaded already.
2281 0 : (tty-find-type #'(lambda (type)
2282 0 : (let ((file (locate-library (concat term-file-prefix type))))
2283 0 : (and file
2284 0 : (or (assoc file load-history)
2285 0 : (load file t t)))))
2286 0 : type)
2287 : ;; Next, try to find a matching initialization function, and call it.
2288 0 : (tty-find-type #'(lambda (type)
2289 0 : (fboundp (setq term-init-func
2290 0 : (intern (concat "terminal-init-" type)))))
2291 0 : type)
2292 0 : (when (fboundp term-init-func)
2293 0 : (funcall term-init-func))
2294 0 : (set-terminal-parameter frame 'terminal-initted term-init-func)
2295 0 : (if run-hook (run-hooks 'tty-setup-hook))))))
2296 :
2297 : ;; Called from C function init_display to initialize faces of the
2298 : ;; dumped terminal frame on startup.
2299 :
2300 : (defun tty-set-up-initial-frame-faces ()
2301 0 : (let ((frame (selected-frame)))
2302 0 : (frame-set-background-mode frame t)
2303 0 : (face-set-after-frame-default frame)))
2304 :
2305 :
2306 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2307 : ;;; Standard faces.
2308 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2309 :
2310 : (defgroup basic-faces nil
2311 : "The standard faces of Emacs."
2312 : :group 'faces)
2313 :
2314 : (defface default
2315 : '((t nil)) ; If this were nil, face-defface-spec would not be set.
2316 : "Basic default face."
2317 : :group 'basic-faces)
2318 :
2319 : (defface bold
2320 : '((t :weight bold))
2321 : "Basic bold face."
2322 : :group 'basic-faces)
2323 :
2324 : (defface italic
2325 : '((((supports :slant italic))
2326 : :slant italic)
2327 : (((supports :underline t))
2328 : :underline t)
2329 : (t
2330 : ;; Default to italic, even if it doesn't appear to be supported,
2331 : ;; because in some cases the display engine will do its own
2332 : ;; workaround (to `dim' on ttys).
2333 : :slant italic))
2334 : "Basic italic face."
2335 : :group 'basic-faces)
2336 :
2337 : (defface bold-italic
2338 : '((t :weight bold :slant italic))
2339 : "Basic bold-italic face."
2340 : :group 'basic-faces)
2341 :
2342 : (defface underline
2343 : '((((supports :underline t))
2344 : :underline t)
2345 : (((supports :weight bold))
2346 : :weight bold)
2347 : (t :underline t))
2348 : "Basic underlined face."
2349 : :group 'basic-faces)
2350 :
2351 : (defface fixed-pitch
2352 : '((t :family "Monospace"))
2353 : "The basic fixed-pitch face."
2354 : :group 'basic-faces)
2355 :
2356 : (defface fixed-pitch-serif
2357 : '((t :family "Monospace Serif"))
2358 : "The basic fixed-pitch face with serifs."
2359 : :group 'basic-faces)
2360 :
2361 : (defface variable-pitch
2362 : '((((type w32))
2363 : ;; This is a workaround for an issue discussed in
2364 : ;; http://lists.gnu.org/archive/html/emacs-devel/2016-04/msg00746.html.
2365 : ;; We need (a) the splash screen not to pick up bold-italics variant of
2366 : ;; the font, and (b) still be able to request bold/italic/larger size
2367 : ;; variants in the likes of EWW.
2368 : :family "Arial" :foundry "outline")
2369 : (t :family "Sans Serif"))
2370 : "The basic variable-pitch face."
2371 : :group 'basic-faces)
2372 :
2373 : (defface shadow
2374 : '((((class color grayscale) (min-colors 88) (background light))
2375 : :foreground "grey50")
2376 : (((class color grayscale) (min-colors 88) (background dark))
2377 : :foreground "grey70")
2378 : (((class color) (min-colors 8) (background light))
2379 : :foreground "green")
2380 : (((class color) (min-colors 8) (background dark))
2381 : :foreground "yellow"))
2382 : "Basic face for shadowed text."
2383 : :group 'basic-faces
2384 : :version "22.1")
2385 :
2386 : (defface link
2387 : '((((class color) (min-colors 88) (background light))
2388 : :foreground "RoyalBlue3" :underline t)
2389 : (((class color) (background light))
2390 : :foreground "blue" :underline t)
2391 : (((class color) (min-colors 88) (background dark))
2392 : :foreground "cyan1" :underline t)
2393 : (((class color) (background dark))
2394 : :foreground "cyan" :underline t)
2395 : (t :inherit underline))
2396 : "Basic face for unvisited links."
2397 : :group 'basic-faces
2398 : :version "22.1")
2399 :
2400 : (defface link-visited
2401 : '((default :inherit link)
2402 : (((class color) (background light)) :foreground "magenta4")
2403 : (((class color) (background dark)) :foreground "violet"))
2404 : "Basic face for visited links."
2405 : :group 'basic-faces
2406 : :version "22.1")
2407 :
2408 : (defface highlight
2409 : '((((class color) (min-colors 88) (background light))
2410 : :background "darkseagreen2")
2411 : (((class color) (min-colors 88) (background dark))
2412 : :background "darkolivegreen")
2413 : (((class color) (min-colors 16) (background light))
2414 : :background "darkseagreen2")
2415 : (((class color) (min-colors 16) (background dark))
2416 : :background "darkolivegreen")
2417 : (((class color) (min-colors 8))
2418 : :background "green" :foreground "black")
2419 : (t :inverse-video t))
2420 : "Basic face for highlighting."
2421 : :group 'basic-faces)
2422 :
2423 : ;; Region face: under NS, default to the system-defined selection
2424 : ;; color (optimized for the fixed white background of other apps),
2425 : ;; if background is light.
2426 : (defface region
2427 : '((((class color) (min-colors 88) (background dark))
2428 : :background "blue3")
2429 : (((class color) (min-colors 88) (background light) (type gtk))
2430 : :distant-foreground "gtk_selection_fg_color"
2431 : :background "gtk_selection_bg_color")
2432 : (((class color) (min-colors 88) (background light) (type ns))
2433 : :distant-foreground "ns_selection_fg_color"
2434 : :background "ns_selection_bg_color")
2435 : (((class color) (min-colors 88) (background light))
2436 : :background "lightgoldenrod2")
2437 : (((class color) (min-colors 16) (background dark))
2438 : :background "blue3")
2439 : (((class color) (min-colors 16) (background light))
2440 : :background "lightgoldenrod2")
2441 : (((class color) (min-colors 8))
2442 : :background "blue" :foreground "white")
2443 : (((type tty) (class mono))
2444 : :inverse-video t)
2445 : (t :background "gray"))
2446 : "Basic face for highlighting the region."
2447 : :version "21.1"
2448 : :group 'basic-faces)
2449 :
2450 : (defface secondary-selection
2451 : '((((class color) (min-colors 88) (background light))
2452 : :background "yellow1")
2453 : (((class color) (min-colors 88) (background dark))
2454 : :background "SkyBlue4")
2455 : (((class color) (min-colors 16) (background light))
2456 : :background "yellow")
2457 : (((class color) (min-colors 16) (background dark))
2458 : :background "SkyBlue4")
2459 : (((class color) (min-colors 8))
2460 : :background "cyan" :foreground "black")
2461 : (t :inverse-video t))
2462 : "Basic face for displaying the secondary selection."
2463 : :group 'basic-faces)
2464 :
2465 : (defface trailing-whitespace
2466 : '((((class color) (background light))
2467 : :background "red1")
2468 : (((class color) (background dark))
2469 : :background "red1")
2470 : (t :inverse-video t))
2471 : "Basic face for highlighting trailing whitespace."
2472 : :version "21.1"
2473 : :group 'basic-faces)
2474 :
2475 : ;; Definition stolen from linum.el.
2476 : (defface line-number
2477 : '((t :inherit (shadow default)))
2478 : "Face for displaying line numbers.
2479 : This face is used when `display-line-numbers' is non-nil.
2480 :
2481 : If you customize the font of this face, make sure it is a
2482 : monospaced font, otherwise line numbers will not line up,
2483 : and text lines might move horizontally as you move through
2484 : the buffer."
2485 : :version "26.1"
2486 : :group 'basic-faces)
2487 :
2488 : (defface line-number-current-line
2489 : '((t :inherit line-number))
2490 : "Face for displaying the current line number.
2491 : This face is used when `display-line-numbers' is non-nil.
2492 :
2493 : If you customize the font of this face, make sure it is a
2494 : monospaced font, otherwise line numbers will not line up,
2495 : and text lines might move horizontally as you move through
2496 : the buffer. Similarly, making this face's font different
2497 : from that of the `line-number' face could produce such
2498 : unwanted effects."
2499 : :version "26.1"
2500 : :group 'basic-faces)
2501 :
2502 : (defface escape-glyph
2503 : '((((background dark)) :foreground "cyan")
2504 : ;; See the comment in minibuffer-prompt for
2505 : ;; the reason not to use blue on MS-DOS.
2506 : (((type pc)) :foreground "magenta")
2507 : ;; red4 is too dark, but some say blue is too loud.
2508 : ;; brown seems to work ok. -- rms.
2509 : (t :foreground "brown"))
2510 : "Face for characters displayed as sequences using `^' or `\\'."
2511 : :group 'basic-faces
2512 : :version "22.1")
2513 :
2514 : (defface homoglyph
2515 : '((((background dark)) :foreground "cyan")
2516 : (((type pc)) :foreground "magenta")
2517 : (t :foreground "brown"))
2518 : "Face for lookalike characters."
2519 : :group 'basic-faces
2520 : :version "26.1")
2521 :
2522 : (defface nobreak-space
2523 : '((((class color) (min-colors 88)) :inherit escape-glyph :underline t)
2524 : (((class color) (min-colors 8)) :background "magenta")
2525 : (t :inverse-video t))
2526 : "Face for displaying nobreak space."
2527 : :group 'basic-faces
2528 : :version "22.1")
2529 :
2530 : (defface nobreak-hyphen
2531 : '((((background dark)) :foreground "cyan")
2532 : (((type pc)) :foreground "magenta")
2533 : (t :foreground "brown"))
2534 : "Face for displaying nobreak hyphens."
2535 : :group 'basic-faces
2536 : :version "26.1")
2537 :
2538 : (defgroup mode-line-faces nil
2539 : "Faces used in the mode line."
2540 : :group 'mode-line
2541 : :group 'faces
2542 : :version "22.1")
2543 :
2544 : (defface mode-line
2545 : '((((class color) (min-colors 88))
2546 : :box (:line-width -1 :style released-button)
2547 : :background "grey75" :foreground "black")
2548 : (t
2549 : :inverse-video t))
2550 : "Basic mode line face for selected window."
2551 : :version "21.1"
2552 : :group 'mode-line-faces
2553 : :group 'basic-faces)
2554 :
2555 : (defface mode-line-inactive
2556 : '((default
2557 : :inherit mode-line)
2558 : (((class color) (min-colors 88) (background light))
2559 : :weight light
2560 : :box (:line-width -1 :color "grey75" :style nil)
2561 : :foreground "grey20" :background "grey90")
2562 : (((class color) (min-colors 88) (background dark) )
2563 : :weight light
2564 : :box (:line-width -1 :color "grey40" :style nil)
2565 : :foreground "grey80" :background "grey30"))
2566 : "Basic mode line face for non-selected windows."
2567 : :version "22.1"
2568 : :group 'mode-line-faces
2569 : :group 'basic-faces)
2570 :
2571 : (defface mode-line-highlight
2572 : '((((class color) (min-colors 88))
2573 : :box (:line-width 2 :color "grey40" :style released-button))
2574 : (t
2575 : :inherit highlight))
2576 : "Basic mode line face for highlighting."
2577 : :version "22.1"
2578 : :group 'mode-line-faces
2579 : :group 'basic-faces)
2580 :
2581 : (defface mode-line-emphasis
2582 : '((t (:weight bold)))
2583 : "Face used to emphasize certain mode line features.
2584 : Use the face `mode-line-highlight' for features that can be selected."
2585 : :version "23.1"
2586 : :group 'mode-line-faces
2587 : :group 'basic-faces)
2588 :
2589 : (defface mode-line-buffer-id
2590 : '((t (:weight bold)))
2591 : "Face used for buffer identification parts of the mode line."
2592 : :version "22.1"
2593 : :group 'mode-line-faces
2594 : :group 'basic-faces)
2595 :
2596 : (defface header-line
2597 : '((default
2598 : :inherit mode-line)
2599 : (((type tty))
2600 : ;; This used to be `:inverse-video t', but that doesn't look very
2601 : ;; good when combined with inverse-video mode-lines and multiple
2602 : ;; windows. Underlining looks better, and is more consistent with
2603 : ;; the window-system face variants, which deemphasize the
2604 : ;; header-line in relation to the mode-line face. If a terminal
2605 : ;; can't underline, then the header-line will end up without any
2606 : ;; highlighting; this may be too confusing in general, although it
2607 : ;; happens to look good with the only current use of header-lines,
2608 : ;; the info browser. XXX
2609 : :inverse-video nil ;Override the value inherited from mode-line.
2610 : :underline t)
2611 : (((class color grayscale) (background light))
2612 : :background "grey90" :foreground "grey20"
2613 : :box nil)
2614 : (((class color grayscale) (background dark))
2615 : :background "grey20" :foreground "grey90"
2616 : :box nil)
2617 : (((class mono) (background light))
2618 : :background "white" :foreground "black"
2619 : :inverse-video nil
2620 : :box nil
2621 : :underline t)
2622 : (((class mono) (background dark))
2623 : :background "black" :foreground "white"
2624 : :inverse-video nil
2625 : :box nil
2626 : :underline t))
2627 : "Basic header-line face."
2628 : :version "21.1"
2629 : :group 'basic-faces)
2630 :
2631 : (defface header-line-highlight '((t :inherit highlight))
2632 : "Basic header line face for highlighting."
2633 : :version "26.1"
2634 : :group 'basic-faces)
2635 :
2636 : (defface vertical-border
2637 : '((((type tty)) :inherit mode-line-inactive))
2638 : "Face used for vertical window dividers on ttys."
2639 : :version "22.1"
2640 : :group 'basic-faces)
2641 :
2642 : (defface window-divider '((t :foreground "gray60"))
2643 : "Basic face for window dividers.
2644 : When a divider is less than 3 pixels wide, it is drawn solidly
2645 : with the foreground of this face. For larger dividers this face
2646 : is used for the inner part while the first pixel line/column is
2647 : drawn with the `window-divider-first-pixel' face and the last
2648 : pixel line/column with the `window-divider-last-pixel' face."
2649 : :version "24.4"
2650 : :group 'window-divider
2651 : :group 'basic-faces)
2652 :
2653 : (defface window-divider-first-pixel
2654 : '((t :foreground "gray80"))
2655 : "Basic face for first pixel line/column of window dividers.
2656 : When a divider is at least 3 pixels wide, its first pixel
2657 : line/column is drawn with the foreground of this face. If you do
2658 : not want to accentuate the first pixel line/column, set this to
2659 : the same as `window-divider' face."
2660 : :version "24.4"
2661 : :group 'window-divider
2662 : :group 'basic-faces)
2663 :
2664 : (defface window-divider-last-pixel
2665 : '((t :foreground "gray40"))
2666 : "Basic face for last pixel line/column of window dividers.
2667 : When a divider is at least 3 pixels wide, its last pixel
2668 : line/column is drawn with the foreground of this face. If you do
2669 : not want to accentuate the last pixel line/column, set this to
2670 : the same as `window-divider' face."
2671 : :version "24.4"
2672 : :group 'window-divider
2673 : :group 'basic-faces)
2674 :
2675 : (defface internal-border
2676 : '((t nil))
2677 : "Basic face for the internal border."
2678 : :version "26.1"
2679 : :group 'frames
2680 : :group 'basic-faces)
2681 :
2682 : (defface minibuffer-prompt
2683 : '((((background dark)) :foreground "cyan")
2684 : ;; Don't use blue because many users of the MS-DOS port customize
2685 : ;; their foreground color to be blue.
2686 : (((type pc)) :foreground "magenta")
2687 : (t :foreground "medium blue"))
2688 : "Face for minibuffer prompts.
2689 : By default, Emacs automatically adds this face to the value of
2690 : `minibuffer-prompt-properties', which is a list of text properties
2691 : used to display the prompt text."
2692 : :version "22.1"
2693 : :group 'basic-faces)
2694 :
2695 : (setq minibuffer-prompt-properties
2696 : (append minibuffer-prompt-properties (list 'face 'minibuffer-prompt)))
2697 :
2698 : (defface fringe
2699 : '((((class color) (background light))
2700 : :background "grey95")
2701 : (((class color) (background dark))
2702 : :background "grey10")
2703 : (t
2704 : :background "gray"))
2705 : "Basic face for the fringes to the left and right of windows under X."
2706 : :version "21.1"
2707 : :group 'frames
2708 : :group 'basic-faces)
2709 :
2710 : (defface scroll-bar '((t nil))
2711 : "Basic face for the scroll bar colors under X."
2712 : :version "21.1"
2713 : :group 'frames
2714 : :group 'basic-faces)
2715 :
2716 : (defface border '((t nil))
2717 : "Basic face for the frame border under X."
2718 : :version "21.1"
2719 : :group 'frames
2720 : :group 'basic-faces)
2721 :
2722 : (defface cursor
2723 : '((((background light)) :background "black")
2724 : (((background dark)) :background "white"))
2725 : "Basic face for the cursor color under X.
2726 : Currently, only the `:background' attribute is meaningful; all
2727 : other attributes are ignored. The cursor foreground color is
2728 : taken from the background color of the underlying text.
2729 :
2730 : Note: Other faces cannot inherit from the cursor face."
2731 : :version "21.1"
2732 : :group 'cursor
2733 : :group 'basic-faces)
2734 :
2735 : (put 'cursor 'face-no-inherit t)
2736 :
2737 : (defface mouse '((t nil))
2738 : "Basic face for the mouse color under X."
2739 : :version "21.1"
2740 : :group 'mouse
2741 : :group 'basic-faces)
2742 :
2743 : (defface tool-bar
2744 : '((default
2745 : :box (:line-width 1 :style released-button)
2746 : :foreground "black")
2747 : (((type x w32 ns) (class color))
2748 : :background "grey75")
2749 : (((type x) (class mono))
2750 : :background "grey"))
2751 : "Basic tool-bar face."
2752 : :version "21.1"
2753 : :group 'basic-faces)
2754 :
2755 : (defface menu
2756 : '((((type tty))
2757 : :inverse-video t)
2758 : (((type x-toolkit))
2759 : )
2760 : (t
2761 : :inverse-video t))
2762 : "Basic face for the font and colors of the menu bar and popup menus."
2763 : :version "21.1"
2764 : :group 'menu
2765 : :group 'basic-faces)
2766 :
2767 : (defface help-argument-name '((t :inherit italic))
2768 : "Face to highlight argument names in *Help* buffers."
2769 : :group 'help)
2770 :
2771 : (defface glyphless-char
2772 : '((((type tty)) :inherit underline)
2773 : (((type pc)) :inherit escape-glyph)
2774 : (t :height 0.6))
2775 : "Face for displaying non-graphic characters (e.g. U+202A (LRE)).
2776 : It is used for characters of no fonts too."
2777 : :version "24.1"
2778 : :group 'basic-faces)
2779 :
2780 : (defface error
2781 : '((default :weight bold)
2782 : (((class color) (min-colors 88) (background light)) :foreground "Red1")
2783 : (((class color) (min-colors 88) (background dark)) :foreground "Pink")
2784 : (((class color) (min-colors 16) (background light)) :foreground "Red1")
2785 : (((class color) (min-colors 16) (background dark)) :foreground "Pink")
2786 : (((class color) (min-colors 8)) :foreground "red")
2787 : (t :inverse-video t))
2788 : "Basic face used to highlight errors and to denote failure."
2789 : :version "24.1"
2790 : :group 'basic-faces)
2791 :
2792 : (defface warning
2793 : '((default :weight bold)
2794 : (((class color) (min-colors 16)) :foreground "DarkOrange")
2795 : (((class color)) :foreground "yellow"))
2796 : "Basic face used to highlight warnings."
2797 : :version "24.1"
2798 : :group 'basic-faces)
2799 :
2800 : (defface success
2801 : '((default :weight bold)
2802 : (((class color) (min-colors 16) (background light)) :foreground "ForestGreen")
2803 : (((class color) (min-colors 88) (background dark)) :foreground "Green1")
2804 : (((class color) (min-colors 16) (background dark)) :foreground "Green")
2805 : (((class color)) :foreground "green"))
2806 : "Basic face used to indicate successful operation."
2807 : :version "24.1"
2808 : :group 'basic-faces)
2809 :
2810 : (defface read-multiple-choice-face
2811 : '((t (:inherit underline
2812 : :weight bold)))
2813 : "Face for the symbol name in `read-multiple-choice' output."
2814 : :group 'basic-faces
2815 : :version "26.1")
2816 :
2817 : ;; Faces for TTY menus.
2818 : (defface tty-menu-enabled-face
2819 : '((t
2820 : :foreground "yellow" :background "blue" :weight bold))
2821 : "Face for displaying enabled items in TTY menus."
2822 : :group 'basic-faces)
2823 :
2824 : (defface tty-menu-disabled-face
2825 : '((((class color) (min-colors 16))
2826 : :foreground "lightgray" :background "blue")
2827 : (t
2828 : :foreground "white" :background "blue"))
2829 : "Face for displaying disabled items in TTY menus."
2830 : :group 'basic-faces)
2831 :
2832 : (defface tty-menu-selected-face
2833 : '((t :background "red"))
2834 : "Face for displaying the currently selected item in TTY menus."
2835 : :group 'basic-faces)
2836 :
2837 : (defgroup paren-showing-faces nil
2838 : "Faces used to highlight paren matches."
2839 : :group 'paren-showing
2840 : :group 'faces
2841 : :version "22.1")
2842 :
2843 : (defface show-paren-match
2844 : '((((class color) (background light))
2845 : :background "turquoise") ; looks OK on tty (becomes cyan)
2846 : (((class color) (background dark))
2847 : :background "steelblue3") ; looks OK on tty (becomes blue)
2848 : (((background dark) (min-colors 4))
2849 : :background "grey50")
2850 : (((background light) (min-colors 4))
2851 : :background "gray")
2852 : (t
2853 : :inherit underline))
2854 : "Face used for a matching paren."
2855 : :group 'paren-showing-faces)
2856 :
2857 : (defface show-paren-match-expression
2858 : '((t :inherit show-paren-match))
2859 : "Face used for a matching paren when highlighting the whole expression.
2860 : This face is used by `show-paren-mode'."
2861 : :group 'paren-showing-faces
2862 : :version "26.1")
2863 :
2864 : (defface show-paren-mismatch
2865 : '((((class color)) (:foreground "white" :background "purple"))
2866 : (t (:inverse-video t)))
2867 : "Face used for a mismatching paren."
2868 : :group 'paren-showing-faces)
2869 :
2870 :
2871 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2872 : ;;; Manipulating font names.
2873 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2874 :
2875 : ;; This is here for compatibility with Emacs 20.2. For example,
2876 : ;; international/fontset.el uses x-resolve-font-name. The following
2877 : ;; functions are not used in the face implementation itself.
2878 :
2879 : (defvar x-font-regexp nil)
2880 : (defvar x-font-regexp-head nil)
2881 : (defvar x-font-regexp-weight nil)
2882 : (defvar x-font-regexp-slant nil)
2883 :
2884 : (defconst x-font-regexp-weight-subnum 1)
2885 : (defconst x-font-regexp-slant-subnum 2)
2886 : (defconst x-font-regexp-swidth-subnum 3)
2887 : (defconst x-font-regexp-adstyle-subnum 4)
2888 :
2889 : ;;; Regexps matching font names in "Host Portable Character Representation."
2890 : ;;;
2891 : (let ((- "[-?]")
2892 : (foundry "[^-]+")
2893 : (family "[^-]+")
2894 : (weight "\\(bold\\|demibold\\|medium\\)") ; 1
2895 : ; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1
2896 : (weight\? "\\([^-]*\\)") ; 1
2897 : (slant "\\([ior]\\)") ; 2
2898 : ; (slant\? "\\([ior?*]?\\)") ; 2
2899 : (slant\? "\\([^-]?\\)") ; 2
2900 : ; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3
2901 : (swidth "\\([^-]*\\)") ; 3
2902 : ; (adstyle "\\(\\*\\|sans\\|\\)") ; 4
2903 : (adstyle "\\([^-]*\\)") ; 4
2904 : (pixelsize "[0-9]+")
2905 : (pointsize "[0-9][0-9]+")
2906 : (resx "[0-9][0-9]+")
2907 : (resy "[0-9][0-9]+")
2908 : (spacing "[cmp?*]")
2909 : (avgwidth "[0-9]+")
2910 : (registry "[^-]+")
2911 : (encoding "[^-]+")
2912 : )
2913 : (setq x-font-regexp
2914 : (purecopy (concat "\\`\\*?[-?*]"
2915 : foundry - family - weight\? - slant\? - swidth - adstyle -
2916 : pixelsize - pointsize - resx - resy - spacing - avgwidth -
2917 : registry - encoding "\\*?\\'"
2918 : )))
2919 : (setq x-font-regexp-head
2920 : (purecopy (concat "\\`[-?*]" foundry - family - weight\? - slant\?
2921 : "\\([-*?]\\|\\'\\)")))
2922 : (setq x-font-regexp-slant (purecopy (concat - slant -)))
2923 : (setq x-font-regexp-weight (purecopy (concat - weight -)))
2924 : nil)
2925 :
2926 :
2927 : (defun x-resolve-font-name (pattern &optional face frame)
2928 : "Return a font name matching PATTERN.
2929 : All wildcards in PATTERN are instantiated.
2930 : If PATTERN is nil, return the name of the frame's base font, which never
2931 : contains wildcards.
2932 : Given optional arguments FACE and FRAME, return a font which is
2933 : also the same size as FACE on FRAME, or fail."
2934 0 : (and (eq frame t)
2935 0 : (setq frame nil))
2936 0 : (if pattern
2937 : ;; Note that x-list-fonts has code to handle a face with nil as its font.
2938 0 : (let ((fonts (x-list-fonts pattern face frame 1)))
2939 0 : (or fonts
2940 0 : (if face
2941 0 : (if (string-match-p "\\*" pattern)
2942 0 : (if (null (face-font face))
2943 0 : (error "No matching fonts are the same height as the frame default font")
2944 0 : (error "No matching fonts are the same height as face `%s'" face))
2945 0 : (if (null (face-font face))
2946 0 : (error "Height of font `%s' doesn't match the frame default font"
2947 0 : pattern)
2948 0 : (error "Height of font `%s' doesn't match face `%s'"
2949 0 : pattern face)))
2950 0 : (error "No fonts match `%s'" pattern)))
2951 0 : (car fonts))
2952 0 : (frame-parameter nil 'font)))
2953 :
2954 : (defcustom font-list-limit 100
2955 : "This variable is obsolete and has no effect."
2956 : :type 'integer
2957 : :group 'display)
2958 : (make-obsolete-variable 'font-list-limit nil "24.3")
2959 :
2960 : (provide 'faces)
2961 :
2962 : ;;; faces.el ends here
|