|
428
|
1 ;;; x-faces.el --- X-specific face frobnication, aka black magic.
|
|
|
2
|
|
3360
|
3 ;; Copyright (C) 1992-1994, 1997, 2006 Free Software Foundation, Inc.
|
|
2527
|
4 ;; Copyright (C) 1995, 1996, 2002, 2004 Ben Wing.
|
|
428
|
5
|
|
|
6 ;; Author: Jamie Zawinski <jwz@jwz.org>
|
|
|
7 ;; Maintainer: XEmacs Development Team
|
|
|
8 ;; Keywords: extensions, internal, dumped
|
|
|
9
|
|
|
10 ;; This file is part of XEmacs.
|
|
|
11
|
|
|
12 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
13 ;; under the terms of the GNU General Public License as published by
|
|
|
14 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
15 ;; any later version.
|
|
|
16
|
|
|
17 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
20 ;; General Public License for more details.
|
|
|
21
|
|
|
22 ;; You should have received a copy of the GNU General Public License
|
|
|
23 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
25 ;; Boston, MA 02111-1307, USA.
|
|
|
26
|
|
|
27 ;;; Synched up with: Not synched.
|
|
|
28
|
|
|
29 ;;; Commentary:
|
|
|
30
|
|
|
31 ;; This file is dumped with XEmacs (when X support is compiled in).
|
|
|
32
|
|
|
33 ;; Modified by: Chuck Thompson
|
|
|
34 ;; Modified by: Ben Wing
|
|
|
35 ;; Modified by: Martin Buchholz
|
|
|
36
|
|
|
37 ;; This file does the magic to parse X font names, and make sure that the
|
|
|
38 ;; default and modeline attributes of new frames are specified enough.
|
|
|
39
|
|
|
40 ;; The resource-manager syntax for faces is
|
|
|
41
|
|
2703
|
42 ;; XEmacs.bold.attributeFont: font-name
|
|
|
43 ;; XEmacs.bold.attributeForeground: fg
|
|
|
44 ;; XEmacs.bold.attributeBackground: bg
|
|
|
45 ;; XEmacs.bold.attributeBackgroundPixmap: file
|
|
|
46 ;; XEmacs.bold.attributeUnderline: true/false
|
|
|
47 ;; XEmacs.bold.attributeStrikethru: true/false
|
|
428
|
48
|
|
|
49 ;; You can specify the properties of a face on a per-frame basis. For
|
|
|
50 ;; example, to have the "isearch" face use a red foreground on frames
|
|
2703
|
51 ;; named "XEmacs" (the default) but use a blue foreground on frames that
|
|
428
|
52 ;; you create named "debugger", you could do
|
|
|
53
|
|
2703
|
54 ;; XEmacs*XEmacs.isearch.attributeForeground: red
|
|
|
55 ;; XEmacs*debugger.isearch.attributeForeground: blue
|
|
428
|
56
|
|
|
57 ;; Generally things that make faces won't set any of the face attributes if
|
|
|
58 ;; you have already given them values via the resource database. You can
|
|
|
59 ;; also change this stuff from your .emacs file, by using the functions
|
|
|
60 ;; set-face-foreground, set-face-font, etc. See the code in this file, and
|
|
|
61 ;; in faces.el.
|
|
|
62
|
|
|
63 ;;; Code:
|
|
|
64
|
|
502
|
65 (globally-declare-fboundp
|
|
|
66 '(x-get-resource-and-maybe-bogosity-check
|
|
|
67 x-get-resource x-init-pointer-shape))
|
|
|
68
|
|
3354
|
69 (if (featurep 'xft-fonts)
|
|
|
70 (require 'fontconfig)
|
|
|
71 (globally-declare-boundp
|
|
|
72 '(fc-font-name-weight-bold fc-font-name-weight-black
|
|
|
73 fc-font-name-weight-demibold fc-font-name-weight-medium
|
|
|
74 fc-font-name-slant-oblique fc-font-name-slant-italic
|
|
|
75 fc-font-name-slant-roman))
|
|
|
76 (globally-declare-fboundp
|
|
3360
|
77 '(fc-pattern-del-size fc-pattern-get-size fc-pattern-add-size
|
|
|
78 fc-pattern-del-style fc-pattern-duplicate fc-copy-pattern-partial
|
|
|
79 fc-pattern-add-weight fc-pattern-del-weight fc-try-font
|
|
|
80 fc-pattern-del-slant fc-pattern-add-slant fc-name-unparse
|
|
|
81 fc-pattern-get-pixelsize)))
|
|
3094
|
82
|
|
428
|
83 (defconst x-font-regexp nil)
|
|
|
84 (defconst x-font-regexp-head nil)
|
|
|
85 (defconst x-font-regexp-head-2 nil)
|
|
|
86 (defconst x-font-regexp-weight nil)
|
|
|
87 (defconst x-font-regexp-slant nil)
|
|
|
88 (defconst x-font-regexp-pixel nil)
|
|
|
89 (defconst x-font-regexp-point nil)
|
|
|
90 (defconst x-font-regexp-foundry-and-family nil)
|
|
|
91 (defconst x-font-regexp-registry-and-encoding nil)
|
|
|
92 (defconst x-font-regexp-spacing nil)
|
|
|
93
|
|
|
94 ;;; Regexps matching font names in "Host Portable Character Representation."
|
|
3094
|
95 ;;; #### But more recently Latin-1 is permitted, and Xft needs it in C (?).
|
|
428
|
96 ;;;
|
|
|
97 (let ((- "[-?]")
|
|
|
98 (foundry "[^-]*")
|
|
|
99 (family "[^-]*")
|
|
|
100 (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1
|
|
|
101 ; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1
|
|
|
102 (weight\? "\\([^-]*\\)") ; 1
|
|
|
103 (slant "\\([ior]\\)") ; 2
|
|
|
104 ; (slant\? "\\([ior?*]?\\)") ; 2
|
|
|
105 (slant\? "\\([^-]?\\)") ; 2
|
|
|
106 ; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3
|
|
|
107 (swidth "\\([^-]*\\)") ; 3
|
|
|
108 ; (adstyle "\\(\\*\\|sans\\|\\)") ; 4
|
|
|
109 (adstyle "\\([^-]*\\)") ; 4
|
|
|
110 (pixelsize "\\(\\*\\|[0-9]+\\)") ; 5
|
|
|
111 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") ; 6
|
|
|
112 ; (resx "\\(\\*\\|[0-9][0-9]+\\)") ; 7
|
|
|
113 ; (resy "\\(\\*\\|[0-9][0-9]+\\)") ; 8
|
|
|
114 (resx "\\([*0]\\|[0-9][0-9]+\\)") ; 7
|
|
|
115 (resy "\\([*0]\\|[0-9][0-9]+\\)") ; 8
|
|
|
116 (spacing "[cmp?*]")
|
|
|
117 (avgwidth "\\(\\*\\|[0-9]+\\)") ; 9
|
|
|
118 (registry "[^-]*") ; some fonts have omitted registries
|
|
|
119 ; (encoding ".+") ; note that encoding may contain "-"...
|
|
|
120 (encoding "[^-]+") ; false!
|
|
|
121 )
|
|
|
122 (setq x-font-regexp
|
|
444
|
123 (concat "\\`\\*?[-?*]"
|
|
|
124 foundry - family - weight\? - slant\? - swidth - adstyle -
|
|
|
125 pixelsize - pointsize - resx - resy - spacing - avgwidth -
|
|
|
126 registry - encoding "\\'"
|
|
|
127 ))
|
|
428
|
128 (setq x-font-regexp-head
|
|
444
|
129 (concat "\\`[-?*]" foundry - family - weight\? - slant\?
|
|
|
130 "\\([-*?]\\|\\'\\)"))
|
|
428
|
131 (setq x-font-regexp-head-2
|
|
444
|
132 (concat "\\`[-?*]" foundry - family - weight\? - slant\?
|
|
|
133 - swidth - adstyle - pixelsize - pointsize
|
|
|
134 "\\([-*?]\\|\\'\\)"))
|
|
|
135 (setq x-font-regexp-slant (concat - slant -))
|
|
|
136 (setq x-font-regexp-weight (concat - weight -))
|
|
428
|
137 ;; if we can't match any of the more specific regexps (unfortunate) then
|
|
|
138 ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits
|
|
|
139 ;; is pixels. Bogus as hell.
|
|
444
|
140 (setq x-font-regexp-pixel "[-?*]\\([0-9][0-9]?\\)[-?*]")
|
|
|
141 (setq x-font-regexp-point "[-?*]\\([0-9][0-9]+\\)[-?*]")
|
|
428
|
142 ;; the following two are used by x-font-menu.el.
|
|
|
143 (setq x-font-regexp-foundry-and-family
|
|
444
|
144 (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))
|
|
428
|
145 (setq x-font-regexp-registry-and-encoding
|
|
444
|
146 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))
|
|
428
|
147 (setq x-font-regexp-spacing
|
|
444
|
148 (concat - "\\(" spacing "\\)" - avgwidth
|
|
|
149 - registry - encoding "\\'"))
|
|
428
|
150 )
|
|
|
151
|
|
3094
|
152 (defun x-font-xlfd-font-name-p (font)
|
|
|
153 "Check if FONT is an XLFD font name"
|
|
|
154 (and (stringp font)
|
|
|
155 (string-match x-font-regexp font)))
|
|
|
156
|
|
428
|
157 ;; A "loser font" is something like "8x13" -> "8x13bold".
|
|
|
158 ;; These are supported only through extreme generosity.
|
|
444
|
159 (defconst x-loser-font-regexp "\\`[0-9]+x[0-9]+\\'")
|
|
428
|
160
|
|
|
161 (defun x-frob-font-weight (font which)
|
|
|
162 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
163 (cond ((null font) nil)
|
|
|
164 ((or (string-match x-font-regexp font)
|
|
|
165 (string-match x-font-regexp-head font)
|
|
|
166 (string-match x-font-regexp-weight font))
|
|
|
167 (concat (substring font 0 (match-beginning 1)) which
|
|
|
168 (substring font (match-end 1))))
|
|
|
169 ((string-match x-loser-font-regexp font)
|
|
|
170 (concat font which))
|
|
|
171 (t nil)))
|
|
|
172
|
|
|
173 (defun x-frob-font-slant (font which)
|
|
|
174 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
175 (cond ((null font) nil)
|
|
|
176 ((or (string-match x-font-regexp font)
|
|
|
177 (string-match x-font-regexp-head font))
|
|
|
178 (concat (substring font 0 (match-beginning 2)) which
|
|
|
179 (substring font (match-end 2))))
|
|
|
180 ((string-match x-font-regexp-slant font)
|
|
|
181 (concat (substring font 0 (match-beginning 1)) which
|
|
|
182 (substring font (match-end 1))))
|
|
|
183 ((string-match x-loser-font-regexp font)
|
|
|
184 (concat font which))
|
|
|
185 (t nil)))
|
|
|
186
|
|
|
187 (defun x-make-font-bold (font &optional device)
|
|
|
188 "Given an X font specification, this attempts to make a `bold' font.
|
|
|
189 If it fails, it returns nil."
|
|
3094
|
190 (if (featurep 'xft-fonts)
|
|
|
191 (if (x-font-xlfd-font-name-p font)
|
|
|
192 (x-make-font-bold-core font device)
|
|
|
193 (x-make-font-bold-xft font device))
|
|
|
194 (x-make-font-bold-core font device)))
|
|
|
195
|
|
|
196 (defun x-make-font-bold-xft (font &optional device)
|
|
3360
|
197 (let ((pattern (fc-font-match (or device (default-x-device))
|
|
|
198 (fc-name-parse font))))
|
|
3094
|
199 (if pattern
|
|
|
200 (let ((size (fc-pattern-get-size pattern 0))
|
|
3354
|
201 (copy (fc-copy-pattern-partial pattern (list "family"))))
|
|
|
202 (fc-pattern-del-weight copy)
|
|
|
203 (fc-pattern-del-style copy)
|
|
3094
|
204 (when copy
|
|
|
205 (or
|
|
|
206 ;; try bold font
|
|
|
207 (let ((copy-2 (fc-pattern-duplicate copy)))
|
|
3354
|
208 (fc-pattern-add-weight copy-2 fc-font-name-weight-bold)
|
|
3094
|
209 (when (fc-try-font copy-2 device)
|
|
3354
|
210 (fc-pattern-add-size copy-2 size)
|
|
3094
|
211 (fc-name-unparse copy-2)))
|
|
|
212 ;; try black font
|
|
|
213 (let ((copy-2 (fc-pattern-duplicate copy)))
|
|
3354
|
214 (fc-pattern-add-weight copy-2 fc-font-name-weight-black)
|
|
3094
|
215 (when (fc-try-font copy-2 device)
|
|
3354
|
216 (fc-pattern-add-size copy-2 size)
|
|
3094
|
217 (fc-name-unparse copy-2)))
|
|
|
218 ;; try demibold font
|
|
|
219 (let ((copy-2 (fc-pattern-duplicate copy)))
|
|
3354
|
220 (fc-pattern-add-weight copy-2 fc-font-name-weight-demibold)
|
|
3094
|
221 (when (fc-try-font copy-2 device)
|
|
3354
|
222 (fc-pattern-add-size copy-2 size)
|
|
3094
|
223 (fc-name-unparse copy-2)))))))))
|
|
|
224
|
|
|
225 (defun x-make-font-bold-core (font &optional device)
|
|
428
|
226 ;; Certain Type1 fonts know "bold" as "black"...
|
|
|
227 (or (try-font-name (x-frob-font-weight font "bold") device)
|
|
|
228 (try-font-name (x-frob-font-weight font "black") device)
|
|
|
229 (try-font-name (x-frob-font-weight font "demibold") device)))
|
|
|
230
|
|
|
231 (defun x-make-font-unbold (font &optional device)
|
|
|
232 "Given an X font specification, this attempts to make a non-bold font.
|
|
|
233 If it fails, it returns nil."
|
|
3094
|
234 (if (featurep 'xft-fonts)
|
|
|
235 (if (x-font-xlfd-font-name-p font)
|
|
|
236 (x-make-font-unbold-core font device)
|
|
|
237 (x-make-font-unbold-xft font device))
|
|
|
238 (x-make-font-unbold-core font device)))
|
|
|
239
|
|
|
240 (defun x-make-font-unbold-xft (font &optional device)
|
|
3360
|
241 (let ((pattern (fc-font-match (or device (default-x-device))
|
|
|
242 (fc-name-parse font))))
|
|
3094
|
243 (when pattern
|
|
3354
|
244 (fc-pattern-del-weight pattern)
|
|
|
245 (fc-pattern-add-weight pattern fc-font-name-weight-medium)
|
|
3094
|
246 (if (fc-try-font pattern device)
|
|
|
247 (fc-name-unparse pattern)))))
|
|
|
248
|
|
|
249 (defun x-make-font-unbold-core (font &optional device)
|
|
428
|
250 (try-font-name (x-frob-font-weight font "medium") device))
|
|
|
251
|
|
|
252 (defcustom try-oblique-before-italic-fonts nil
|
|
|
253 "*If nil, italic fonts are searched before oblique fonts.
|
|
|
254 If non-nil, oblique fonts are tried before italic fonts. This is mostly
|
|
|
255 applicable to adobe-courier fonts"
|
|
|
256 :type 'boolean
|
|
|
257 :group 'x)
|
|
|
258 (define-obsolete-variable-alias '*try-oblique-before-italic-fonts*
|
|
|
259 'try-oblique-before-italic-fonts)
|
|
|
260
|
|
|
261 (defun x-make-font-italic (font &optional device)
|
|
|
262 "Given an X font specification, this attempts to make an `italic' font.
|
|
|
263 If it fails, it returns nil."
|
|
3094
|
264 (if (featurep 'xft-fonts)
|
|
|
265 (if (x-font-xlfd-font-name-p font)
|
|
|
266 (x-make-font-italic-core font device)
|
|
|
267 (x-make-font-italic-xft font device))
|
|
|
268 (x-make-font-italic-core font device)))
|
|
|
269
|
|
|
270 (defun x-make-font-italic-xft (font &optional device)
|
|
3360
|
271 (let ((pattern (fc-font-match (or device (default-x-device))
|
|
|
272 (fc-name-parse font))))
|
|
3094
|
273 (if pattern
|
|
|
274 (let ((size (fc-pattern-get-size pattern 0))
|
|
3354
|
275 (copy (fc-copy-pattern-partial pattern (list "family"))))
|
|
3094
|
276 (when copy
|
|
3354
|
277 (fc-pattern-del-slant copy)
|
|
|
278 (fc-pattern-del-style copy)
|
|
|
279 ;; #### can't we do this with one ambiguous pattern?
|
|
3094
|
280 (let ((pattern-oblique (fc-pattern-duplicate copy))
|
|
|
281 (pattern-italic (fc-pattern-duplicate copy)))
|
|
3354
|
282 (fc-pattern-add-slant pattern-oblique fc-font-name-slant-oblique)
|
|
|
283 (fc-pattern-add-slant pattern-italic fc-font-name-slant-italic)
|
|
3094
|
284 (let ((have-oblique (fc-try-font pattern-oblique device))
|
|
|
285 (have-italic (fc-try-font pattern-italic device)))
|
|
|
286 (if try-oblique-before-italic-fonts
|
|
|
287 (if have-oblique
|
|
|
288 (progn
|
|
|
289 (if size
|
|
3354
|
290 (fc-pattern-add-size pattern-oblique size))
|
|
3094
|
291 (fc-name-unparse pattern-oblique))
|
|
|
292 (if have-italic
|
|
|
293 (progn
|
|
|
294 (if size
|
|
3354
|
295 (fc-pattern-add-size pattern-italic size))
|
|
3094
|
296 (fc-name-unparse pattern-italic))))
|
|
|
297 (if have-italic
|
|
|
298 (progn
|
|
|
299 (if size
|
|
3354
|
300 (fc-pattern-add-size pattern-italic size))
|
|
3094
|
301 (fc-name-unparse pattern-italic))
|
|
|
302 (if have-oblique
|
|
|
303 (progn
|
|
|
304 (if size
|
|
3354
|
305 (fc-pattern-add-size pattern-oblique size))
|
|
3094
|
306 (fc-name-unparse pattern-oblique))))))))))))
|
|
|
307
|
|
|
308 (defun x-make-font-italic-core (font &optional device)
|
|
428
|
309 (if try-oblique-before-italic-fonts
|
|
|
310 (or (try-font-name (x-frob-font-slant font "o") device)
|
|
|
311 (try-font-name (x-frob-font-slant font "i") device))
|
|
|
312 (or (try-font-name (x-frob-font-slant font "i") device)
|
|
|
313 (try-font-name (x-frob-font-slant font "o") device))))
|
|
|
314
|
|
|
315 (defun x-make-font-unitalic (font &optional device)
|
|
|
316 "Given an X font specification, this attempts to make a non-italic font.
|
|
|
317 If it fails, it returns nil."
|
|
3094
|
318 (if (featurep 'xft-fonts)
|
|
|
319 (if (x-font-xlfd-font-name-p font)
|
|
|
320 (x-make-font-unitalic-core font device)
|
|
|
321 (x-make-font-unitalic-xft font device))
|
|
|
322 (x-make-font-unitalic-core font device)))
|
|
|
323
|
|
|
324 (defun x-make-font-unitalic-xft (font &optional device)
|
|
3360
|
325 (let ((pattern (fc-font-match (or device (default-x-device))
|
|
|
326 (fc-name-parse font))))
|
|
3094
|
327 (when pattern
|
|
3354
|
328 (fc-pattern-del-slant pattern)
|
|
|
329 (fc-pattern-add-slant pattern fc-font-name-slant-roman)
|
|
3094
|
330 (if (fc-try-font pattern device)
|
|
|
331 (fc-name-unparse pattern)))))
|
|
|
332
|
|
|
333 (defun x-make-font-unitalic-core (font &optional device)
|
|
428
|
334 (try-font-name (x-frob-font-slant font "r") device))
|
|
|
335
|
|
|
336 (defun x-make-font-bold-italic (font &optional device)
|
|
|
337 "Given an X font specification, this attempts to make a `bold-italic' font.
|
|
|
338 If it fails, it returns nil."
|
|
3094
|
339 (if (featurep 'xft-fonts)
|
|
|
340 (if (x-font-xlfd-font-name-p font)
|
|
|
341 (x-make-font-bold-italic-core font device)
|
|
|
342 (x-make-font-bold-italic-xft font device))
|
|
|
343 (x-make-font-bold-italic-core font device)))
|
|
|
344
|
|
|
345 (defun x-make-font-bold-italic-xft (font &optional device)
|
|
|
346 (let ((italic (x-make-font-italic-xft font device)))
|
|
|
347 (if italic
|
|
|
348 (x-make-font-bold-xft italic device))))
|
|
|
349
|
|
|
350 (defun x-make-font-bold-italic-core (font &optional device)
|
|
428
|
351 ;; This is haired up to avoid loading the "intermediate" fonts.
|
|
442
|
352 (if try-oblique-before-italic-fonts
|
|
428
|
353 (or (try-font-name
|
|
|
354 (x-frob-font-slant (x-frob-font-weight font "bold") "o") device)
|
|
|
355 (try-font-name
|
|
|
356 (x-frob-font-slant (x-frob-font-weight font "bold") "i") device)
|
|
|
357 (try-font-name
|
|
|
358 (x-frob-font-slant (x-frob-font-weight font "black") "o") device)
|
|
|
359 (try-font-name
|
|
|
360 (x-frob-font-slant (x-frob-font-weight font "black") "i") device)
|
|
|
361 (try-font-name
|
|
|
362 (x-frob-font-slant (x-frob-font-weight font "demibold") "o") device)
|
|
|
363 (try-font-name
|
|
|
364 (x-frob-font-slant (x-frob-font-weight font "demibold") "i") device))
|
|
|
365 (or (try-font-name
|
|
|
366 (x-frob-font-slant (x-frob-font-weight font "bold") "i") device)
|
|
|
367 (try-font-name
|
|
|
368 (x-frob-font-slant (x-frob-font-weight font "bold") "o") device)
|
|
|
369 (try-font-name
|
|
|
370 (x-frob-font-slant (x-frob-font-weight font "black") "i") device)
|
|
|
371 (try-font-name
|
|
|
372 (x-frob-font-slant (x-frob-font-weight font "black") "o") device)
|
|
|
373 (try-font-name
|
|
|
374 (x-frob-font-slant (x-frob-font-weight font "demibold") "i") device)
|
|
|
375 (try-font-name
|
|
|
376 (x-frob-font-slant (x-frob-font-weight font "demibold") "o") device))))
|
|
|
377
|
|
|
378 (defun x-font-size (font)
|
|
|
379 "Return the nominal size of the given font.
|
|
|
380 This is done by parsing its name, so it's likely to lose.
|
|
|
381 X fonts can be specified (by the user) in either pixels or 10ths of points,
|
|
|
382 and this returns the first one it finds, so you have to decide which units
|
|
|
383 the returned value is measured in yourself..."
|
|
3094
|
384 (if (featurep 'xft-fonts)
|
|
|
385 (if (x-font-xlfd-font-name-p font)
|
|
|
386 (x-font-size-core font)
|
|
|
387 (x-font-size-xft font))
|
|
|
388 (x-font-size-core font)))
|
|
|
389
|
|
|
390 ;; this is unbelievable &*@#
|
|
|
391 (defun x-font-size-xft (font)
|
|
3360
|
392 (let ((pattern (fc-font-match (default-x-device)
|
|
|
393 (fc-name-parse font))))
|
|
3094
|
394 (when pattern
|
|
|
395 (let ((pixelsize (fc-pattern-get-pixelsize pattern 0)))
|
|
3360
|
396 (if (floatp pixelsize) (round pixelsize) pixelsize)))))
|
|
3094
|
397
|
|
|
398 (defun x-font-size-core (font)
|
|
428
|
399 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
400 (cond ((or (string-match x-font-regexp font)
|
|
|
401 (string-match x-font-regexp-head-2 font))
|
|
|
402 (string-to-int (substring font (match-beginning 6) (match-end 6))))
|
|
|
403 ((or (string-match x-font-regexp-pixel font)
|
|
|
404 (string-match x-font-regexp-point font))
|
|
|
405 (string-to-int (substring font (match-beginning 1) (match-end 1))))
|
|
|
406 (t nil)))
|
|
|
407
|
|
|
408 ;; Given a font name, this function returns a list describing all fonts
|
|
|
409 ;; of all sizes that otherwise match the given font spec. Each element
|
|
|
410 ;; in the list is a list of three items: the pixel size of the font,
|
|
|
411 ;; the point size (in 1/10ths of a point) of the font, and the fully-
|
|
|
412 ;; qualified font name. The first two values may be zero; this
|
|
|
413 ;; refers to a scalable font.
|
|
|
414
|
|
|
415 (defun x-available-font-sizes (font device)
|
|
|
416 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
417 (cond ((string-match x-font-regexp font)
|
|
|
418 ;; turn pixelsize, pointsize, and avgwidth into wildcards
|
|
|
419 (setq font
|
|
|
420 (concat (substring font 0 (match-beginning 5)) "*"
|
|
|
421 (substring font (match-end 5) (match-beginning 6)) "*"
|
|
|
422 (substring font (match-end 6) (match-beginning 9)) "*"
|
|
|
423 (substring font (match-end 9) (match-end 0)))))
|
|
|
424 ((string-match x-font-regexp-head-2 font)
|
|
|
425 ;; turn pixelsize and pointsize into wildcards
|
|
|
426 (setq font
|
|
|
427 (concat (substring font 0 (match-beginning 5)) "*"
|
|
|
428 (substring font (match-end 5) (match-beginning 6)) "*"
|
|
|
429 (substring font (match-end 6) (match-end 0)))))
|
|
|
430 ((string-match "[-?*]\\([0-9]+\\)[-?*]" font)
|
|
|
431 ;; Turn the first integer we match into a wildcard.
|
|
|
432 ;; This is pretty dubious...
|
|
|
433 (setq font
|
|
|
434 (concat (substring font 0 (match-beginning 1)) "*"
|
|
|
435 (substring font (match-end 1) (match-end 0))))))
|
|
|
436 (sort
|
|
|
437 (delq nil
|
|
|
438 (mapcar (function
|
|
|
439 (lambda (name)
|
|
|
440 (and (string-match x-font-regexp name)
|
|
|
441 (list
|
|
|
442 (string-to-int (substring name (match-beginning 5)
|
|
|
443 (match-end 5)))
|
|
|
444 (string-to-int (substring name (match-beginning 6)
|
|
|
445 (match-end 6)))
|
|
|
446 name))))
|
|
2527
|
447 (font-list font device)))
|
|
428
|
448 (function (lambda (x y) (if (= (nth 1 x) (nth 1 y))
|
|
|
449 (< (nth 0 x) (nth 0 y))
|
|
|
450 (< (nth 1 x) (nth 1 y)))))))
|
|
|
451
|
|
|
452 ;; Given a font name, this attempts to construct a valid font name for
|
|
|
453 ;; DEVICE whose size is the next smaller (if UP-P is nil) or larger
|
|
|
454 ;; (if UP-P is t) size and whose other characteristics are the same
|
|
|
455 ;; as the given font.
|
|
|
456
|
|
|
457 (defun x-frob-font-size (font up-p device)
|
|
|
458 (if (stringp font) (setq font (make-font-instance font device)))
|
|
|
459 (if (font-instance-p font) (setq font (font-instance-truename font)))
|
|
|
460 (let ((available (and font
|
|
|
461 (x-available-font-sizes font device))))
|
|
|
462 (cond
|
|
|
463 ((null available) nil)
|
|
|
464 ((or (= 0 (nth 0 (car available)))
|
|
|
465 (= 0 (nth 1 (car available))))
|
|
|
466 ;; R5 scalable fonts: change size by 1 point.
|
|
|
467 ;; If they're scalable the first font will have pixel or point = 0.
|
|
|
468 ;; Sometimes one is 0 and the other isn't (if it's a bitmap font that
|
|
|
469 ;; can be scaled), sometimes both are (if it's a true outline font).
|
|
|
470 (let ((name (nth 2 (car available)))
|
|
|
471 old-size)
|
|
|
472 (or (string-match x-font-regexp font) (error "can't parse %S" font))
|
|
|
473 (setq old-size (string-to-int
|
|
|
474 (substring font (match-beginning 6) (match-end 6))))
|
|
|
475 (or (> old-size 0) (error "font truename has 0 pointsize?"))
|
|
|
476 (or (string-match x-font-regexp name) (error "can't parse %S" name))
|
|
|
477 ;; turn pixelsize into a wildcard, and make pointsize be +/- 10,
|
|
|
478 ;; which is +/- 1 point. All other fields stay the same as they
|
|
|
479 ;; were in the "template" font returned by x-available-font-sizes.
|
|
|
480 ;;
|
|
|
481 ;; #### But this might return the same font: for example, if the
|
|
|
482 ;; truename of "-*-courier-medium-r-normal--*-230-75-75-m-0-*"
|
|
|
483 ;; is "...-240-..." (instead of 230) then this loses, because
|
|
|
484 ;; the 230 that was passed in as an arg got turned into 240
|
|
|
485 ;; by the call to font-instance-truename; then we decrement that
|
|
|
486 ;; by 10 and return the result which is the same. I think the
|
|
|
487 ;; way to fix this is to make this be a loop that keeps trying
|
|
|
488 ;; progressively larger pointsize deltas until it finds one
|
|
|
489 ;; whose truename differs. Have to be careful to avoid infinite
|
|
|
490 ;; loops at the upper end...
|
|
|
491 ;;
|
|
|
492 (concat (substring name 0 (match-beginning 5)) "*"
|
|
|
493 (substring name (match-end 5) (match-beginning 6))
|
|
|
494 (int-to-string (+ old-size (if up-p 10 -10)))
|
|
|
495 (substring name (match-end 6) (match-end 0)))))
|
|
|
496 (t
|
|
|
497 ;; non-scalable fonts: take the next available size.
|
|
|
498 (let ((rest available)
|
|
|
499 (last nil)
|
|
|
500 result)
|
|
|
501 (while rest
|
|
801
|
502 (cond ((and (not up-p) (equalp font (nth 2 (car rest))))
|
|
428
|
503 (setq result last
|
|
|
504 rest nil))
|
|
801
|
505 ((and up-p (equalp font (and last (nth 2 last))))
|
|
428
|
506 (setq result (car rest)
|
|
|
507 rest nil)))
|
|
|
508 (setq last (car rest))
|
|
|
509 (setq rest (cdr rest)))
|
|
|
510 (nth 2 result))))))
|
|
|
511
|
|
|
512 (defun x-find-smaller-font (font &optional device)
|
|
|
513 "Load a new, slightly smaller version of the given font (or font name).
|
|
|
514 Returns the font if it succeeds, nil otherwise.
|
|
|
515 If scalable fonts are available, this returns a font which is 1 point smaller.
|
|
|
516 Otherwise, it returns the next smaller version of this font that is defined."
|
|
3094
|
517 (if (featurep 'xft-fonts)
|
|
|
518 (if (x-font-xlfd-font-name-p font)
|
|
|
519 (x-find-smaller-font-core font device)
|
|
|
520 (x-find-smaller-font-xft font device))
|
|
|
521 (x-find-smaller-font-core font device)))
|
|
|
522
|
|
|
523 (defun x-find-xft-font-of-size (font new-size-proc &optional device)
|
|
3360
|
524 (let* ((pattern (fc-font-match (or device (default-x-device))
|
|
|
525 (fc-name-parse font))))
|
|
3094
|
526 (when pattern
|
|
|
527 (let ((size (fc-pattern-get-size pattern 0)))
|
|
|
528 (if (floatp size)
|
|
|
529 (let ((copy (fc-pattern-duplicate pattern)))
|
|
3354
|
530 (fc-pattern-del-size copy)
|
|
|
531 (fc-pattern-add-size copy (funcall new-size-proc size))
|
|
3094
|
532 (if (fc-try-font font device)
|
|
|
533 (fc-name-unparse copy))))))))
|
|
|
534
|
|
|
535 (defun x-find-smaller-font-xft (font &optional device)
|
|
|
536 (x-find-xft-font-of-size font '(lambda (old-size) (- old-size 1.0)) device))
|
|
|
537
|
|
|
538 (defun x-find-smaller-font-core (font &optional device)
|
|
428
|
539 (x-frob-font-size font nil device))
|
|
|
540
|
|
|
541 (defun x-find-larger-font (font &optional device)
|
|
|
542 "Load a new, slightly larger version of the given font (or font name).
|
|
|
543 Returns the font if it succeeds, nil otherwise.
|
|
|
544 If scalable fonts are available, this returns a font which is 1 point larger.
|
|
|
545 Otherwise, it returns the next larger version of this font that is defined."
|
|
3094
|
546 (if (featurep 'xft-fonts)
|
|
|
547 (if (x-font-xlfd-font-name-p font)
|
|
|
548 (x-find-larger-font-core font device)
|
|
|
549 (x-find-larger-font-xft font device))
|
|
|
550 (x-find-larger-font-core font device)))
|
|
|
551
|
|
|
552 (defun x-find-larger-font-xft (font &optional device)
|
|
|
553 (x-find-xft-font-of-size font '(lambda (old-size) (+ old-size 1.0)) device))
|
|
|
554
|
|
|
555 (defun x-find-larger-font-core (font &optional device)
|
|
428
|
556 (x-frob-font-size font t device))
|
|
|
557
|
|
|
558 (defalias 'x-make-face-bold 'make-face-bold)
|
|
|
559 (defalias 'x-make-face-italic 'make-face-italic)
|
|
|
560 (defalias 'x-make-face-bold-italic 'make-face-bold-italic)
|
|
|
561 (defalias 'x-make-face-unbold 'make-face-unbold)
|
|
|
562 (defalias 'x-make-face-unitalic 'make-face-unitalic)
|
|
|
563
|
|
|
564 (make-obsolete 'x-make-face-bold 'make-face-bold)
|
|
|
565 (make-obsolete 'x-make-face-italic 'make-face-italic)
|
|
|
566 (make-obsolete 'x-make-face-bold-italic 'make-face-bold-italic)
|
|
|
567 (make-obsolete 'x-make-face-unbold 'make-face-unbold)
|
|
|
568 (make-obsolete 'x-make-face-unitalic 'make-face-unitalic)
|
|
|
569
|
|
|
570
|
|
2527
|
571
|
|
|
572 ;; #### - wrong place for this variable? Exactly. We probably want
|
|
|
573 ;; `color-list' to be a console method, so `tty-color-list' becomes
|
|
|
574 ;; obsolete, and `read-color-completion-table' conses (mapcar #'list
|
|
|
575 ;; (color-list)), optionally caching the results.
|
|
|
576
|
|
|
577 ;; Ben wanted all of the possibilities from the `configure' script used
|
|
|
578 ;; here, but I think this is way too many. I already trimmed the R4 variants
|
|
|
579 ;; and a few obvious losers from the list. --Stig
|
|
|
580 (defvar x-library-search-path '("/usr/X11R6/lib/X11/"
|
|
|
581 "/usr/X11R5/lib/X11/"
|
|
|
582 "/usr/lib/X11R6/X11/"
|
|
|
583 "/usr/lib/X11R5/X11/"
|
|
|
584 "/usr/local/X11R6/lib/X11/"
|
|
|
585 "/usr/local/X11R5/lib/X11/"
|
|
|
586 "/usr/local/lib/X11R6/X11/"
|
|
|
587 "/usr/local/lib/X11R5/X11/"
|
|
|
588 "/usr/X11/lib/X11/"
|
|
|
589 "/usr/lib/X11/"
|
|
3125
|
590 "/usr/share/X11/"
|
|
2527
|
591 "/usr/local/lib/X11/"
|
|
3125
|
592 "/usr/local/share/X11/"
|
|
2527
|
593 "/usr/X386/lib/X11/"
|
|
|
594 "/usr/x386/lib/X11/"
|
|
|
595 "/usr/XFree86/lib/X11/"
|
|
|
596 "/usr/unsupported/lib/X11/"
|
|
|
597 "/usr/athena/lib/X11/"
|
|
|
598 "/usr/local/x11r5/lib/X11/"
|
|
|
599 "/usr/lpp/Xamples/lib/X11/"
|
|
|
600 "/usr/openwin/lib/X11/"
|
|
|
601 "/usr/openwin/share/lib/X11/")
|
|
|
602 "Search path used by `x-color-list-internal' to find rgb.txt.")
|
|
|
603
|
|
|
604 (defvar x-color-list-internal-cache)
|
|
|
605
|
|
|
606 (defun x-color-list-internal ()
|
|
|
607 (if (boundp 'x-color-list-internal-cache)
|
|
|
608 x-color-list-internal-cache
|
|
|
609 (let ((rgb-file (locate-file "rgb.txt" x-library-search-path))
|
|
|
610 clist color p)
|
|
|
611 (if (not rgb-file)
|
|
|
612 ;; prevents multiple searches for rgb.txt if we can't find it
|
|
|
613 (setq x-color-list-internal-cache nil)
|
|
|
614 (with-current-buffer (get-buffer-create " *colors*")
|
|
|
615 (reset-buffer (current-buffer))
|
|
|
616 (insert-file-contents rgb-file)
|
|
|
617 (while (not (eobp))
|
|
|
618 ;; skip over comments
|
|
|
619 (while (looking-at "^!")
|
|
|
620 (end-of-line)
|
|
|
621 (forward-char 1))
|
|
|
622 (skip-chars-forward "0-9 \t")
|
|
|
623 (setq p (point))
|
|
|
624 (end-of-line)
|
|
|
625 (setq color (buffer-substring p (point))
|
|
|
626 clist (cons (list color) clist))
|
|
|
627 ;; Ugh. If we want to be able to complete the lowercase form
|
|
|
628 ;; of the color name, we need to add it twice! Yuck.
|
|
|
629 (let ((dcase (downcase color)))
|
|
|
630 (or (string= dcase color)
|
|
|
631 (push (list dcase) clist)))
|
|
|
632 (forward-char 1))
|
|
|
633 (kill-buffer (current-buffer))))
|
|
|
634 (setq x-color-list-internal-cache clist)
|
|
|
635 x-color-list-internal-cache)))
|
|
|
636
|
|
|
637
|
|
428
|
638 ;;; internal routines
|
|
|
639
|
|
|
640 ;;; x-init-face-from-resources is responsible for initializing a
|
|
|
641 ;;; newly-created face from the resource database.
|
|
|
642 ;;;
|
|
|
643 ;;; When a new frame is created, it is called from `x-init-frame-faces'
|
|
|
644 ;;; called from `init-frame-faces' called from init_frame_faces()
|
|
|
645 ;;; from Fmake_frame(). In this case it is called once for each existing
|
|
|
646 ;;; face, with the newly-created frame as the argument. It then initializes
|
|
|
647 ;;; the newly-created faces on that frame.
|
|
|
648 ;;;
|
|
|
649 ;;; It's also called from `init-device-faces' and
|
|
|
650 ;;; `init-global-faces'.
|
|
|
651 ;;;
|
|
|
652 ;;; This had better not signal an error. The frame is in an intermediate
|
|
|
653 ;;; state where signalling an error or entering the debugger would likely
|
|
|
654 ;;; result in a crash.
|
|
|
655
|
|
|
656 (defun x-init-face-from-resources (face &optional locale set-anyway)
|
|
|
657
|
|
|
658 ;;
|
|
|
659 ;; These are things like "attributeForeground" instead of simply
|
|
|
660 ;; "foreground" because people tend to do things like "*foreground",
|
|
|
661 ;; which would cause all faces to be fully qualified, making faces
|
|
|
662 ;; inherit attributes in a non-useful way. So we've made them slightly
|
|
|
663 ;; less obvious to specify in order to make them work correctly in
|
|
|
664 ;; more random environments.
|
|
|
665 ;;
|
|
|
666 ;; I think these should be called "face.faceForeground" instead of
|
|
|
667 ;; "face.attributeForeground", but they're the way they are for
|
|
|
668 ;; hysterical reasons. (jwz)
|
|
|
669
|
|
|
670 (let* ((append (if set-anyway nil 'append))
|
|
|
671 ;; Some faces are initialized before XEmacs is dumped.
|
|
|
672 ;; In order for the X resources to be able to override
|
|
|
673 ;; those settings, such initialization always uses the
|
|
|
674 ;; `default' tag. We remove all specifier specs
|
|
|
675 ;; containing the `default' tag in the locale before
|
|
|
676 ;; adding new specs.
|
|
|
677 (tag-set '(default))
|
|
|
678 ;; The tag order matters here. The spec removal
|
|
|
679 ;; function uses the list cdrs. We want to remove (x
|
|
|
680 ;; default) and (default) specs, not (default x) and (x)
|
|
|
681 ;; specs.
|
|
|
682 (x-tag-set '(x default))
|
|
|
683 (tty-tag-set '(tty default))
|
|
|
684 (device-class nil)
|
|
|
685 (face-sym (face-name face))
|
|
|
686 (name (symbol-name face-sym))
|
|
|
687 (fn (x-get-resource-and-maybe-bogosity-check
|
|
|
688 (concat name ".attributeFont")
|
|
|
689 "Face.AttributeFont"
|
|
|
690 'string locale))
|
|
|
691 (fg (x-get-resource-and-maybe-bogosity-check
|
|
|
692 (concat name ".attributeForeground")
|
|
|
693 "Face.AttributeForeground"
|
|
|
694 'string locale))
|
|
|
695 (bg (x-get-resource-and-maybe-bogosity-check
|
|
|
696 (concat name ".attributeBackground")
|
|
|
697 "Face.AttributeBackground"
|
|
|
698 'string locale))
|
|
|
699 (bgp (x-get-resource-and-maybe-bogosity-check
|
|
|
700 (concat name ".attributeBackgroundPixmap")
|
|
|
701 "Face.AttributeBackgroundPixmap"
|
|
|
702 'string locale))
|
|
|
703 (ulp (x-get-resource-and-maybe-bogosity-check
|
|
|
704 (concat name ".attributeUnderline")
|
|
|
705 "Face.AttributeUnderline"
|
|
|
706 'boolean locale))
|
|
|
707 (stp (x-get-resource-and-maybe-bogosity-check
|
|
|
708 (concat name ".attributeStrikethru")
|
|
|
709 "Face.AttributeStrikethru"
|
|
|
710 'boolean locale))
|
|
|
711 ;; we still resource for these TTY-only resources so that
|
|
|
712 ;; you can specify resources for TTY frames/devices. This is
|
|
|
713 ;; useful when you start up your XEmacs on an X display and later
|
|
|
714 ;; open some TTY frames.
|
|
|
715 (hp (x-get-resource-and-maybe-bogosity-check
|
|
|
716 (concat name ".attributeHighlight")
|
|
|
717 "Face.AttributeHighlight"
|
|
|
718 'boolean locale))
|
|
|
719 (dp (x-get-resource-and-maybe-bogosity-check
|
|
|
720 (concat name ".attributeDim")
|
|
|
721 "Face.AttributeDim"
|
|
|
722 'boolean locale))
|
|
|
723 (bp (x-get-resource-and-maybe-bogosity-check
|
|
|
724 (concat name ".attributeBlinking")
|
|
|
725 "Face.AttributeBlinking"
|
|
|
726 'boolean locale))
|
|
|
727 (rp (x-get-resource-and-maybe-bogosity-check
|
|
|
728 (concat name ".attributeReverse")
|
|
|
729 "Face.AttributeReverse"
|
|
|
730 'boolean locale))
|
|
|
731 )
|
|
|
732
|
|
|
733 (cond ((framep locale)
|
|
|
734 (setq device-class (device-class (frame-device locale))))
|
|
|
735 ((devicep locale)
|
|
|
736 (setq device-class (device-class locale))))
|
|
|
737
|
|
|
738 (if device-class
|
|
|
739 (setq tag-set (cons device-class tag-set)
|
|
|
740 x-tag-set (cons device-class x-tag-set)
|
|
|
741 tty-tag-set (cons device-class tty-tag-set)))
|
|
|
742
|
|
|
743 ;;
|
|
|
744 ;; If this is the default face, then any unspecified properties should
|
|
|
745 ;; be defaulted from the global properties. Can't do this for
|
|
|
746 ;; frames or devices because then, common resource specs like
|
|
|
747 ;; "*Foreground: black" will have unwanted effects.
|
|
|
748 ;;
|
|
|
749 (if (and (or (eq (face-name face) 'default)
|
|
|
750 (eq (face-name face) 'gui-element))
|
|
|
751 (or (null locale) (eq locale 'global)))
|
|
|
752 (progn
|
|
|
753 (or fn (setq fn (x-get-resource
|
|
442
|
754 "font" "Font" 'string locale nil 'warn)))
|
|
428
|
755 (or fg (setq fg (x-get-resource
|
|
442
|
756 "foreground" "Foreground" 'string locale nil
|
|
|
757 'warn)))
|
|
428
|
758 (or bg (setq bg (x-get-resource
|
|
442
|
759 "background" "Background" 'string locale nil
|
|
|
760 'warn)))))
|
|
428
|
761 ;;
|
|
|
762 ;; "*cursorColor: foo" is equivalent to setting the background of the
|
|
|
763 ;; text-cursor face.
|
|
|
764 ;;
|
|
|
765 (if (and (eq (face-name face) 'text-cursor)
|
|
|
766 (or (null locale) (eq locale 'global)))
|
|
|
767 (setq bg (or (x-get-resource
|
|
442
|
768 "cursorColor" "CursorColor" 'string locale nil 'warn)
|
|
|
769 bg)))
|
|
428
|
770 ;; #### should issue warnings? I think this should be
|
|
|
771 ;; done when the instancing actually happens, but I'm not
|
|
|
772 ;; sure how it should actually be dealt with.
|
|
|
773 (when fn
|
|
|
774 (if device-class
|
|
|
775 ;; Always use the x-tag-set to remove specs, since we don't
|
|
|
776 ;; know whether the predumped face was initialized with an
|
|
|
777 ;; 'x tag or not.
|
|
|
778 (remove-specifier-specs-matching-tag-set-cdrs (face-font face)
|
|
|
779 locale
|
|
|
780 x-tag-set)
|
|
|
781 ;; If there's no device class then we're initializing
|
|
|
782 ;; globally. This means we should override global
|
|
|
783 ;; defaults for all X device classes.
|
|
|
784 (remove-specifier (face-font face) locale x-tag-set nil))
|
|
3659
|
785 (set-face-font face fn locale 'x append)
|
|
|
786 ;
|
|
|
787 ; (debug-print "the face is %s, locale %s, specifier %s"
|
|
|
788 ; face locale (face-font face))
|
|
|
789 ;
|
|
|
790 ;; And retain some of the fallbacks in the generated default face,
|
|
|
791 ;; since we don't want to try andale-mono's ISO-10646-1 encoding for
|
|
|
792 ;; Amharic or Thai. This is fragile; it depends on the code in
|
|
|
793 ;; faces.c.
|
|
|
794 (dolist (assocked '((x encode-as-utf-8 initial)
|
|
|
795 (x two-dimensional initial)
|
|
|
796 (x one-dimensional final)
|
|
|
797 (x two-dimensional final)))
|
|
|
798 (when (and (specifierp (face-font face))
|
|
|
799 (consp (specifier-fallback (face-font face)))
|
|
|
800 (setq assocked
|
|
|
801 (assoc assocked
|
|
|
802 (specifier-fallback
|
|
|
803 (face-font face)))))
|
|
|
804 (set-face-font face (cdr assocked) locale
|
|
|
805 (nreverse (car assocked)) append))))
|
|
|
806
|
|
428
|
807 ;; Kludge-o-rooni. Set the foreground and background resources for
|
|
|
808 ;; X devices only -- otherwise things tend to get all messed up
|
|
|
809 ;; if you start up an X frame and then later create a TTY frame.
|
|
|
810 (when fg
|
|
|
811 (if device-class
|
|
|
812 (remove-specifier-specs-matching-tag-set-cdrs (face-foreground face)
|
|
|
813 locale
|
|
|
814 x-tag-set)
|
|
|
815 (remove-specifier (face-foreground face) locale x-tag-set nil))
|
|
|
816 (set-face-foreground face fg locale 'x append))
|
|
|
817 (when bg
|
|
|
818 (if device-class
|
|
|
819 (remove-specifier-specs-matching-tag-set-cdrs (face-background face)
|
|
|
820 locale
|
|
|
821 x-tag-set)
|
|
|
822 (remove-specifier (face-background face) locale x-tag-set nil))
|
|
|
823 (set-face-background face bg locale 'x append))
|
|
|
824 (when bgp
|
|
|
825 (if device-class
|
|
|
826 (remove-specifier-specs-matching-tag-set-cdrs (face-background-pixmap
|
|
|
827 face)
|
|
|
828 locale
|
|
|
829 x-tag-set)
|
|
|
830 (remove-specifier (face-background-pixmap face) locale x-tag-set nil))
|
|
|
831 (set-face-background-pixmap face bgp locale nil append))
|
|
|
832 (when ulp
|
|
|
833 (if device-class
|
|
|
834 (remove-specifier-specs-matching-tag-set-cdrs (face-property
|
|
|
835 face 'underline)
|
|
|
836 locale
|
|
|
837 tty-tag-set)
|
|
|
838 (remove-specifier (face-property face 'underline) locale
|
|
|
839 tty-tag-set nil))
|
|
|
840 (set-face-underline-p face ulp locale nil append))
|
|
|
841 (when stp
|
|
|
842 (if device-class
|
|
|
843 (remove-specifier-specs-matching-tag-set-cdrs (face-property
|
|
|
844 face 'strikethru)
|
|
|
845 locale
|
|
|
846 tty-tag-set)
|
|
|
847 (remove-specifier (face-property face 'strikethru)
|
|
|
848 locale tty-tag-set nil))
|
|
|
849 (set-face-strikethru-p face stp locale nil append))
|
|
|
850 (when hp
|
|
|
851 (if device-class
|
|
|
852 (remove-specifier-specs-matching-tag-set-cdrs (face-property
|
|
|
853 face 'highlight)
|
|
|
854 locale
|
|
|
855 tty-tag-set)
|
|
|
856 (remove-specifier (face-property face 'highlight)
|
|
|
857 locale tty-tag-set nil))
|
|
|
858 (set-face-highlight-p face hp locale nil append))
|
|
|
859 (when dp
|
|
|
860 (if device-class
|
|
|
861 (remove-specifier-specs-matching-tag-set-cdrs (face-property
|
|
|
862 face 'dim)
|
|
|
863 locale
|
|
|
864 tty-tag-set)
|
|
|
865 (remove-specifier (face-property face 'dim) locale tty-tag-set nil))
|
|
|
866 (set-face-dim-p face dp locale nil append))
|
|
|
867 (when bp
|
|
|
868 (if device-class
|
|
|
869 (remove-specifier-specs-matching-tag-set-cdrs (face-property
|
|
|
870 face 'blinking)
|
|
|
871 locale
|
|
|
872 tty-tag-set)
|
|
|
873 (remove-specifier (face-property face 'blinking) locale
|
|
|
874 tty-tag-set nil))
|
|
|
875 (set-face-blinking-p face bp locale nil append))
|
|
|
876 (when rp
|
|
|
877 (if device-class
|
|
|
878 (remove-specifier-specs-matching-tag-set-cdrs (face-property
|
|
|
879 face 'reverse)
|
|
|
880 locale
|
|
|
881 tty-tag-set)
|
|
|
882 (remove-specifier (face-property face 'reverse) locale
|
|
|
883 tty-tag-set nil))
|
|
|
884 (set-face-reverse-p face rp locale nil append))
|
|
|
885 ))
|
|
|
886
|
|
|
887 ;; GNU Emacs compatibility. (move to obsolete.el?)
|
|
|
888 (defalias 'make-face-x-resource-internal 'x-init-face-from-resources)
|
|
|
889
|
|
|
890 (defun remove-specifier-specs-matching-tag-set-cdrs (specifier locale tag-set)
|
|
|
891 (while tag-set
|
|
|
892 (remove-specifier specifier locale tag-set t)
|
|
|
893 (setq tag-set (cdr tag-set))))
|
|
|
894
|
|
|
895 ;;; x-init-global-faces is responsible for ensuring that the
|
|
|
896 ;;; default face has some reasonable fallbacks if nothing else is
|
|
|
897 ;;; specified.
|
|
|
898 ;;;
|
|
|
899 (defun x-init-global-faces ()
|
|
|
900 (or (face-foreground 'default 'global)
|
|
|
901 (set-face-foreground 'default "black" 'global '(x default)))
|
|
|
902 (or (face-background 'default 'global)
|
|
|
903 (set-face-background 'default "gray80" 'global '(x default))))
|
|
|
904
|
|
|
905 ;;; x-init-device-faces is responsible for initializing default
|
|
|
906 ;;; values for faces on a newly created device.
|
|
|
907 ;;;
|
|
|
908 (defun x-init-device-faces (device)
|
|
|
909 ;;
|
|
|
910 ;; If the "default" face didn't have a font specified, try to pick one.
|
|
|
911 ;;
|
|
872
|
912 ;; (or
|
|
|
913 ;; (face-font-instance 'default device)
|
|
|
914 ;;
|
|
|
915 ;; [[ No font specified in the resource database; try to cope. ]]
|
|
|
916 ;;
|
|
|
917 ;; NOTE: In reality, this will never happen. The fallbacks will always
|
|
|
918 ;; be tried, and the last fallback is "*", which should get any font. No
|
|
|
919 ;; need to put the same checks here as in the fallbacks. These comments
|
|
|
920 ;; appear to be pre-19.12. --ben
|
|
428
|
921
|
|
872
|
922 ;; [[ At first I wanted to do this by just putting a font-spec in the
|
|
|
923 ;; fallback resources passed to XtAppInitialize(), but that fails
|
|
|
924 ;; if there is an Emacs app-defaults file which doesn't specify a
|
|
|
925 ;; font: apparently the fallback resources are not consulted when
|
|
|
926 ;; there is an app-defaults file, which seems pretty bogus to me.
|
|
|
927 ;;
|
|
|
928 ;; We should also probably try "*xtDefaultFont", but I think that it
|
|
|
929 ;; might be legal to specify that as "xtDefaultFont:", that is, at
|
|
|
930 ;; top level, instead of "*xtDefaultFont:", that is, applicable to
|
|
|
931 ;; every application. `x-get-resource' can't handle that right now.
|
|
|
932 ;; Anyway, xtDefaultFont is probably variable-width.
|
|
|
933 ;;
|
|
|
934 ;; Some who have LucidaTypewriter think it's a better font than Courier,
|
|
|
935 ;; but it has the bug that there are no italic and bold italic versions.
|
|
|
936 ;; We could hair this code up to try and mix-and-match fonts to get a
|
|
|
937 ;; full complement, but really, why bother. It's just a default. ]]
|
|
|
938 ;;
|
|
|
939 ;; [[ We default to looking for iso8859 fonts. Using a wildcard for the
|
|
|
940 ;; encoding would be bad, because that can cause English speakers to get
|
|
|
941 ;; Kanji fonts by default. It is safe to assume that people using a
|
|
|
942 ;; language other than English have both set $LANG, and have specified
|
|
|
943 ;; their `font' and `fontList' resources. In any event, it's better to
|
|
|
944 ;; err on the side of the English speaker in this case because they are
|
|
|
945 ;; much less likely to have encountered this problem, and are thus less
|
|
|
946 ;; likely to know what to do about it. ]]
|
|
|
947
|
|
|
948
|
|
428
|
949 ;;
|
|
|
950 ;; If the "default" face didn't have both colors specified, then pick
|
|
|
951 ;; some, taking into account whether one of the colors was specified.
|
|
|
952 ;;
|
|
|
953 (let ((fg (face-foreground-instance 'default device))
|
|
|
954 (bg (face-background-instance 'default device)))
|
|
|
955 (if (not (and fg bg))
|
|
801
|
956 (if (or (and fg (equalp (color-instance-name fg) "white"))
|
|
|
957 (and bg (equalp (color-instance-name bg) "black")))
|
|
428
|
958 (progn
|
|
|
959 (or fg (set-face-foreground 'default "white" device))
|
|
|
960 (or bg (set-face-background 'default "black" device)))
|
|
|
961 (or fg (set-face-foreground 'default "white" device))
|
|
|
962 (or bg (set-face-background 'default "black" device)))))
|
|
|
963
|
|
|
964 ;; Don't look at reverseVideo now or initialize the modeline. This
|
|
|
965 ;; is done on a per-frame basis at the appropriate time.
|
|
|
966
|
|
|
967 ;;
|
|
|
968 ;; Now let's try to pick some reasonable defaults for a few other faces.
|
|
|
969 ;; This kind of stuff should normally go on the create-frame-hook, but
|
|
|
970 ;; this way we won't be in danger of the user screwing things up by not
|
|
|
971 ;; adding hooks in a safe way.
|
|
|
972 ;;
|
|
|
973 (x-init-pointer-shape device) ; from x-mouse.el
|
|
|
974 )
|
|
|
975
|
|
|
976 ;;; This is called from `init-frame-faces', which is called from
|
|
|
977 ;;; init_frame_faces() which is called from Fmake_frame(), to perform
|
|
|
978 ;;; any device-specific initialization.
|
|
|
979 ;;;
|
|
|
980 (defun x-init-frame-faces (frame)
|
|
|
981 ;;
|
|
|
982 ;; The faces already got initialized (by init-frame-faces) from
|
|
|
983 ;; the resource database or global, non-frame faces. The default,
|
|
|
984 ;; bold, bold-italic, and italic faces (plus various other random faces)
|
|
|
985 ;; got set up then. But modeline didn't so that reverseVideo can be
|
|
|
986 ;; frame-specific.
|
|
|
987 ;;
|
|
|
988
|
|
|
989 ;;
|
|
|
990 ;; If reverseVideo was specified, swap the foreground and background
|
|
|
991 ;; of the default and modeline faces.
|
|
|
992 ;;
|
|
442
|
993 (cond ((car (x-get-resource "reverseVideo" "ReverseVideo" 'boolean frame
|
|
|
994 nil 'warn))
|
|
428
|
995 ;; First make sure the modeline has fg and bg, inherited from the
|
|
|
996 ;; current default face - for the case where only one is specified,
|
|
|
997 ;; so that invert-face doesn't do something weird.
|
|
|
998 (or (face-foreground 'modeline frame)
|
|
|
999 (set-face-foreground 'modeline
|
|
|
1000 (face-foreground-instance 'default frame)
|
|
|
1001 frame))
|
|
|
1002 (or (face-background 'modeline frame)
|
|
|
1003 (set-face-background 'modeline
|
|
|
1004 (face-background-instance 'default frame)
|
|
|
1005 frame))
|
|
|
1006 ;; Now invert both of them. If they end up looking the same,
|
|
|
1007 ;; make-frame-initial-faces will invert the modeline again later.
|
|
|
1008 (invert-face 'default frame)
|
|
|
1009 (invert-face 'modeline frame)
|
|
|
1010 )))
|
|
|
1011
|
|
|
1012 ;;; x-faces.el ends here
|
