|
0
|
1 ;;; x-faces.el --- X-specific face frobnication, aka black magic.
|
|
|
2
|
|
|
3 ;;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
|
|
|
4 ;;; Copyright (C) 1995, 1996 Ben Wing.
|
|
|
5
|
|
151
|
6 ;; Author: Jamie Zawinski
|
|
|
7 ;; Modified by: Chuck Thompson
|
|
|
8 ;; Modified by: Ben Wing
|
|
|
9 ;; Modified by: Martin Buchholz
|
|
0
|
10
|
|
|
11 ;; This file is part of XEmacs.
|
|
|
12
|
|
|
13 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
14 ;; under the terms of the GNU General Public License as published by
|
|
|
15 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
16 ;; any later version.
|
|
|
17
|
|
|
18 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
21 ;; General Public License for more details.
|
|
|
22
|
|
|
23 ;; You should have received a copy of the GNU General Public License
|
|
70
|
24 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
26 ;; Boston, MA 02111-1307, USA.
|
|
0
|
27
|
|
|
28 ;; This file does the magic to parse X font names, and make sure that the
|
|
|
29 ;; default and modeline attributes of new frames are specified enough.
|
|
|
30 ;;
|
|
|
31 ;; The resource-manager syntax for faces is
|
|
|
32 ;;
|
|
|
33 ;; Emacs.bold.attributeFont: font-name
|
|
|
34 ;; Emacs.bold.attributeForeground: fg
|
|
|
35 ;; Emacs.bold.attributeBackground: bg
|
|
|
36 ;; Emacs.bold.attributeBackgroundPixmap: file
|
|
|
37 ;; Emacs.bold.attributeUnderline: true/false
|
|
|
38 ;; Emacs.bold.attributeStrikethru: true/false
|
|
|
39 ;;
|
|
|
40 ;; You can specify the properties of a face on a per-frame basis. For
|
|
|
41 ;; example, to have the "isearch" face use a red foreground on frames
|
|
|
42 ;; named "emacs" (the default) but use a blue foreground on frames that
|
|
|
43 ;; you create named "debugger", you could do
|
|
|
44 ;;
|
|
|
45 ;; Emacs*emacs.isearch.attributeForeground: red
|
|
|
46 ;; Emacs*debugger.isearch.attributeForeground: blue
|
|
|
47 ;;
|
|
|
48 ;; Generally things that make faces won't set any of the face attributes if
|
|
|
49 ;; you have already given them values via the resource database. You can
|
|
|
50 ;; also change this stuff from your .emacs file, by using the functions
|
|
|
51 ;; set-face-foreground, set-face-font, etc. See the code in this file, and
|
|
|
52 ;; in faces.el.
|
|
|
53
|
|
|
54 (defconst x-font-regexp nil)
|
|
|
55 (defconst x-font-regexp-head nil)
|
|
|
56 (defconst x-font-regexp-head-2 nil)
|
|
|
57 (defconst x-font-regexp-weight nil)
|
|
|
58 (defconst x-font-regexp-slant nil)
|
|
|
59 (defconst x-font-regexp-pixel nil)
|
|
|
60 (defconst x-font-regexp-point nil)
|
|
|
61 (defconst x-font-regexp-foundry-and-family nil)
|
|
|
62 (defconst x-font-regexp-registry-and-encoding nil)
|
|
|
63 (defconst x-font-regexp-spacing nil)
|
|
|
64
|
|
|
65 ;;; Regexps matching font names in "Host Portable Character Representation."
|
|
|
66 ;;;
|
|
|
67 (let ((- "[-?]")
|
|
|
68 (foundry "[^-]*")
|
|
|
69 (family "[^-]*")
|
|
|
70 (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1
|
|
|
71 ; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1
|
|
|
72 (weight\? "\\([^-]*\\)") ; 1
|
|
|
73 (slant "\\([ior]\\)") ; 2
|
|
|
74 ; (slant\? "\\([ior?*]?\\)") ; 2
|
|
|
75 (slant\? "\\([^-]?\\)") ; 2
|
|
|
76 ; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3
|
|
|
77 (swidth "\\([^-]*\\)") ; 3
|
|
|
78 ; (adstyle "\\(\\*\\|sans\\|\\)") ; 4
|
|
|
79 (adstyle "\\([^-]*\\)") ; 4
|
|
|
80 (pixelsize "\\(\\*\\|[0-9]+\\)") ; 5
|
|
|
81 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") ; 6
|
|
|
82 ; (resx "\\(\\*\\|[0-9][0-9]+\\)") ; 7
|
|
|
83 ; (resy "\\(\\*\\|[0-9][0-9]+\\)") ; 8
|
|
|
84 (resx "\\([*0]\\|[0-9][0-9]+\\)") ; 7
|
|
|
85 (resy "\\([*0]\\|[0-9][0-9]+\\)") ; 8
|
|
|
86 (spacing "[cmp?*]")
|
|
|
87 (avgwidth "\\(\\*\\|[0-9]+\\)") ; 9
|
|
|
88 (registry "[^-]*") ; some fonts have omitted registries
|
|
|
89 ; (encoding ".+") ; note that encoding may contain "-"...
|
|
|
90 (encoding "[^-]+") ; false!
|
|
|
91 )
|
|
|
92 (setq x-font-regexp
|
|
|
93 (purecopy
|
|
|
94 (concat "\\`\\*?[-?*]"
|
|
|
95 foundry - family - weight\? - slant\? - swidth - adstyle -
|
|
|
96 pixelsize - pointsize - resx - resy - spacing - avgwidth -
|
|
|
97 registry - encoding "\\'"
|
|
|
98 )))
|
|
|
99 (setq x-font-regexp-head
|
|
|
100 (purecopy
|
|
|
101 (concat "\\`[-?*]" foundry - family - weight\? - slant\?
|
|
|
102 "\\([-*?]\\|\\'\\)")))
|
|
|
103 (setq x-font-regexp-head-2
|
|
|
104 (purecopy
|
|
|
105 (concat "\\`[-?*]" foundry - family - weight\? - slant\?
|
|
|
106 - swidth - adstyle - pixelsize - pointsize
|
|
|
107 "\\([-*?]\\|\\'\\)")))
|
|
|
108 (setq x-font-regexp-slant (purecopy (concat - slant -)))
|
|
|
109 (setq x-font-regexp-weight (purecopy (concat - weight -)))
|
|
|
110 ;; if we can't match any of the more specific regexps (unfortunate) then
|
|
|
111 ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits
|
|
|
112 ;; is pixels. Bogus as hell.
|
|
|
113 (setq x-font-regexp-pixel (purecopy "[-?*]\\([0-9][0-9]?\\)[-?*]"))
|
|
|
114 (setq x-font-regexp-point (purecopy "[-?*]\\([0-9][0-9]+\\)[-?*]"))
|
|
|
115 ;; the following two are used by x-font-menu.el.
|
|
|
116 (setq x-font-regexp-foundry-and-family
|
|
|
117 (purecopy (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)))
|
|
|
118 (setq x-font-regexp-registry-and-encoding
|
|
|
119 (purecopy (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")))
|
|
|
120 (setq x-font-regexp-spacing
|
|
|
121 (purecopy (concat - "\\(" spacing "\\)" - avgwidth
|
|
|
122 - registry - encoding "\\'")))
|
|
|
123 )
|
|
|
124
|
|
|
125 ;; A "loser font" is something like "8x13" -> "8x13bold".
|
|
|
126 ;; These are supported only through extreme generosity.
|
|
|
127 (defconst x-loser-font-regexp (purecopy "\\`[0-9]+x[0-9]+\\'"))
|
|
|
128
|
|
|
129 (defun x-frob-font-weight (font which)
|
|
|
130 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
131 (cond ((null font) nil)
|
|
|
132 ((or (string-match x-font-regexp font)
|
|
|
133 (string-match x-font-regexp-head font)
|
|
|
134 (string-match x-font-regexp-weight font))
|
|
|
135 (concat (substring font 0 (match-beginning 1)) which
|
|
|
136 (substring font (match-end 1))))
|
|
|
137 ((string-match x-loser-font-regexp font)
|
|
|
138 (concat font which))
|
|
|
139 (t nil)))
|
|
|
140
|
|
|
141 (defun x-frob-font-slant (font which)
|
|
|
142 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
143 (cond ((null font) nil)
|
|
|
144 ((or (string-match x-font-regexp font)
|
|
|
145 (string-match x-font-regexp-head font))
|
|
|
146 (concat (substring font 0 (match-beginning 2)) which
|
|
|
147 (substring font (match-end 2))))
|
|
|
148 ((string-match x-font-regexp-slant font)
|
|
|
149 (concat (substring font 0 (match-beginning 1)) which
|
|
|
150 (substring font (match-end 1))))
|
|
|
151 ((string-match x-loser-font-regexp font)
|
|
|
152 (concat font which))
|
|
|
153 (t nil)))
|
|
|
154
|
|
|
155 (defun try-font-name (name &optional device)
|
|
|
156 ;; yes, name really should be here twice.
|
|
|
157 (and name (make-font-instance name device t) name))
|
|
|
158
|
|
|
159 (defun x-make-font-bold (font &optional device)
|
|
|
160 "Given an X font specification, this attempts to make a `bold' font.
|
|
|
161 If it fails, it returns nil."
|
|
|
162 ;; Certain Type1 fonts know "bold" as "black"...
|
|
|
163 (or (try-font-name (x-frob-font-weight font "bold") device)
|
|
|
164 (try-font-name (x-frob-font-weight font "black") device)
|
|
|
165 (try-font-name (x-frob-font-weight font "demibold") device)))
|
|
|
166
|
|
|
167 (defun x-make-font-unbold (font &optional device)
|
|
|
168 "Given an X font specification, this attempts to make a non-bold font.
|
|
|
169 If it fails, it returns nil."
|
|
|
170 (try-font-name (x-frob-font-weight font "medium") device))
|
|
|
171
|
|
108
|
172 (defvar *try-oblique-before-italic-fonts* nil
|
|
|
173 "*If NIL, italic fonts are searched before oblique fonts. If
|
|
|
174 non-NIL, oblique fonts are tried before italic fonts. This is mostly
|
|
|
175 applicable to adobe-courier fonts")
|
|
|
176
|
|
0
|
177 (defun x-make-font-italic (font &optional device)
|
|
|
178 "Given an X font specification, this attempts to make an `italic' font.
|
|
|
179 If it fails, it returns nil."
|
|
108
|
180 (if *try-oblique-before-italic-fonts*
|
|
|
181 (or (try-font-name (x-frob-font-slant font "o") device)
|
|
|
182 (try-font-name (x-frob-font-slant font "i") device))
|
|
|
183 (or (try-font-name (x-frob-font-slant font "i") device)
|
|
|
184 (try-font-name (x-frob-font-slant font "o") device))))
|
|
0
|
185
|
|
|
186 (defun x-make-font-unitalic (font &optional device)
|
|
|
187 "Given an X font specification, this attempts to make a non-italic font.
|
|
|
188 If it fails, it returns nil."
|
|
|
189 (try-font-name (x-frob-font-slant font "r") device))
|
|
|
190
|
|
|
191 (defun x-make-font-bold-italic (font &optional device)
|
|
|
192 "Given an X font specification, this attempts to make a `bold-italic' font.
|
|
|
193 If it fails, it returns nil."
|
|
|
194 ;; This is haired up to avoid loading the "intermediate" fonts.
|
|
|
195 (or (try-font-name
|
|
|
196 (x-frob-font-slant (x-frob-font-weight font "bold") "i") device)
|
|
|
197 (try-font-name
|
|
|
198 (x-frob-font-slant (x-frob-font-weight font "bold") "o") device)
|
|
|
199 (try-font-name
|
|
|
200 (x-frob-font-slant (x-frob-font-weight font "black") "i") device)
|
|
|
201 (try-font-name
|
|
|
202 (x-frob-font-slant (x-frob-font-weight font "black") "o") device)
|
|
|
203 (try-font-name
|
|
|
204 (x-frob-font-slant (x-frob-font-weight font "demibold") "i") device)
|
|
|
205 (try-font-name
|
|
|
206 (x-frob-font-slant (x-frob-font-weight font "demibold") "o") device)))
|
|
|
207
|
|
|
208 (defun x-font-size (font)
|
|
|
209 "Return the nominal size of the given font.
|
|
|
210 This is done by parsing its name, so it's likely to lose.
|
|
|
211 X fonts can be specified (by the user) in either pixels or 10ths of points,
|
|
|
212 and this returns the first one it finds, so you have to decide which units
|
|
|
213 the returned value is measured in yourself..."
|
|
|
214 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
215 (cond ((or (string-match x-font-regexp font)
|
|
|
216 (string-match x-font-regexp-head-2 font))
|
|
|
217 (string-to-int (substring font (match-beginning 6) (match-end 6))))
|
|
|
218 ((or (string-match x-font-regexp-pixel font)
|
|
|
219 (string-match x-font-regexp-point font))
|
|
|
220 (string-to-int (substring font (match-beginning 1) (match-end 1))))
|
|
|
221 (t nil)))
|
|
|
222
|
|
|
223 ;; Given a font name, this function returns a list describing all fonts
|
|
|
224 ;; of all sizes that otherwise match the given font spec. Each element
|
|
|
225 ;; in the list is a list of three items: the pixel size of the font,
|
|
|
226 ;; the point size (in 1/10ths of a point) of the font, and the fully-
|
|
|
227 ;; qualified font name. The first two values may be zero; this
|
|
|
228 ;; refers to a scalable font.
|
|
|
229
|
|
|
230 (defun x-available-font-sizes (font device)
|
|
|
231 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
232 (cond ((string-match x-font-regexp font)
|
|
|
233 ;; turn pixelsize, pointsize, and avgwidth into wildcards
|
|
|
234 (setq font
|
|
|
235 (concat (substring font 0 (match-beginning 5)) "*"
|
|
|
236 (substring font (match-end 5) (match-beginning 6)) "*"
|
|
|
237 (substring font (match-end 6) (match-beginning 9)) "*"
|
|
|
238 (substring font (match-end 9) (match-end 0)))))
|
|
|
239 ((string-match x-font-regexp-head-2 font)
|
|
|
240 ;; turn pixelsize and pointsize into wildcards
|
|
|
241 (setq font
|
|
|
242 (concat (substring font 0 (match-beginning 5)) "*"
|
|
|
243 (substring font (match-end 5) (match-beginning 6)) "*"
|
|
|
244 (substring font (match-end 6) (match-end 0)))))
|
|
|
245 ((string-match "[-?*]\\([0-9]+\\)[-?*]" font)
|
|
|
246 ;; Turn the first integer we match into a wildcard.
|
|
|
247 ;; This is pretty dubious...
|
|
|
248 (setq font
|
|
|
249 (concat (substring font 0 (match-beginning 1)) "*"
|
|
|
250 (substring font (match-end 1) (match-end 0))))))
|
|
|
251 (sort
|
|
|
252 (delq nil
|
|
|
253 (mapcar (function
|
|
|
254 (lambda (name)
|
|
|
255 (and (string-match x-font-regexp name)
|
|
|
256 (list
|
|
|
257 (string-to-int (substring name (match-beginning 5)
|
|
|
258 (match-end 5)))
|
|
|
259 (string-to-int (substring name (match-beginning 6)
|
|
|
260 (match-end 6)))
|
|
|
261 name))))
|
|
|
262 (list-fonts font device)))
|
|
|
263 (function (lambda (x y) (if (= (nth 1 x) (nth 1 y))
|
|
|
264 (< (nth 0 x) (nth 0 y))
|
|
|
265 (< (nth 1 x) (nth 1 y)))))))
|
|
|
266
|
|
|
267 ;; Given a font name, this attempts to construct a valid font name for
|
|
|
268 ;; DEVICE whose size is the next smaller (if UP-P is nil) or larger
|
|
|
269 ;; (if UP-P is t) size and whose other characteristics are the same
|
|
|
270 ;; as the given font.
|
|
|
271
|
|
|
272 (defun x-frob-font-size (font up-p device)
|
|
|
273 (if (stringp font) (setq font (make-font-instance font device)))
|
|
|
274 (if (font-instance-p font) (setq font (font-instance-truename font)))
|
|
|
275 (let ((available (and font
|
|
|
276 (x-available-font-sizes font device))))
|
|
|
277 (cond
|
|
|
278 ((null available) nil)
|
|
|
279 ((or (= 0 (nth 0 (car available)))
|
|
|
280 (= 0 (nth 1 (car available))))
|
|
|
281 ;; R5 scalable fonts: change size by 1 point.
|
|
|
282 ;; If they're scalable the first font will have pixel or point = 0.
|
|
|
283 ;; Sometimes one is 0 and the other isn't (if it's a bitmap font that
|
|
|
284 ;; can be scaled), sometimes both are (if it's a true outline font).
|
|
|
285 (let ((name (nth 2 (car available)))
|
|
|
286 old-size)
|
|
|
287 (or (string-match x-font-regexp font) (error "can't parse %S" font))
|
|
|
288 (setq old-size (string-to-int
|
|
|
289 (substring font (match-beginning 6) (match-end 6))))
|
|
|
290 (or (> old-size 0) (error "font truename has 0 pointsize?"))
|
|
|
291 (or (string-match x-font-regexp name) (error "can't parse %S" name))
|
|
|
292 ;; turn pixelsize into a wildcard, and make pointsize be +/- 10,
|
|
|
293 ;; which is +/- 1 point. All other fields stay the same as they
|
|
|
294 ;; were in the "template" font returned by x-available-font-sizes.
|
|
|
295 ;;
|
|
|
296 ;; #### But this might return the same font: for example, if the
|
|
|
297 ;; truename of "-*-courier-medium-r-normal--*-230-75-75-m-0-*"
|
|
|
298 ;; is "...-240-..." (instead of 230) then this loses, because
|
|
|
299 ;; the 230 that was passed in as an arg got turned into 240
|
|
|
300 ;; by the call to font-instance-truename; then we decrement that
|
|
|
301 ;; by 10 and return the result which is the same. I think the
|
|
|
302 ;; way to fix this is to make this be a loop that keeps trying
|
|
|
303 ;; progressively larger pointsize deltas until it finds one
|
|
|
304 ;; whose truename differs. Have to be careful to avoid infinite
|
|
|
305 ;; loops at the upper end...
|
|
|
306 ;;
|
|
|
307 (concat (substring name 0 (match-beginning 5)) "*"
|
|
|
308 (substring name (match-end 5) (match-beginning 6))
|
|
|
309 (int-to-string (+ old-size (if up-p 10 -10)))
|
|
|
310 (substring name (match-end 6) (match-end 0)))))
|
|
|
311 (t
|
|
|
312 ;; non-scalable fonts: take the next available size.
|
|
|
313 (let ((rest available)
|
|
|
314 (last nil)
|
|
|
315 result)
|
|
|
316 (setq font (downcase font))
|
|
|
317 (while rest
|
|
|
318 (cond ((and (not up-p) (equal font (downcase (nth 2 (car rest)))))
|
|
|
319 (setq result last
|
|
|
320 rest nil))
|
|
|
321 ((and up-p (equal font (and last (downcase (nth 2 last)))))
|
|
|
322 (setq result (car rest)
|
|
|
323 rest nil)))
|
|
|
324 (setq last (car rest))
|
|
|
325 (setq rest (cdr rest)))
|
|
|
326 (nth 2 result))))))
|
|
|
327
|
|
|
328 (defun x-find-smaller-font (font &optional device)
|
|
|
329 "Loads a new, slightly smaller version of the given font (or font name).
|
|
|
330 Returns the font if it succeeds, nil otherwise.
|
|
|
331 If scalable fonts are available, this returns a font which is 1 point smaller.
|
|
|
332 Otherwise, it returns the next smaller version of this font that is defined."
|
|
|
333 (x-frob-font-size font nil device))
|
|
|
334
|
|
|
335 (defun x-find-larger-font (font &optional device)
|
|
|
336 "Loads a new, slightly larger version of the given font (or font name).
|
|
|
337 Returns the font if it succeeds, nil otherwise.
|
|
|
338 If scalable fonts are available, this returns a font which is 1 point larger.
|
|
|
339 Otherwise, it returns the next larger version of this font that is defined."
|
|
|
340 (x-frob-font-size font t device))
|
|
|
341
|
|
|
342 (defalias 'x-make-face-bold 'make-face-bold)
|
|
|
343 (defalias 'x-make-face-italic 'make-face-italic)
|
|
|
344 (defalias 'x-make-face-bold-italic 'make-face-bold-italic)
|
|
|
345 (defalias 'x-make-face-unbold 'make-face-unbold)
|
|
|
346 (defalias 'x-make-face-unitalic 'make-face-unitalic)
|
|
|
347
|
|
|
348 (make-obsolete 'x-make-face-bold 'make-face-bold)
|
|
|
349 (make-obsolete 'x-make-face-italic 'make-face-italic)
|
|
|
350 (make-obsolete 'x-make-face-bold-italic 'make-face-bold-italic)
|
|
|
351 (make-obsolete 'x-make-face-unbold 'make-face-unbold)
|
|
|
352 (make-obsolete 'x-make-face-unitalic 'make-face-unitalic)
|
|
|
353
|
|
|
354
|
|
|
355 ;; Define some logical color names to be used when reading the pixmap files.
|
|
|
356 (if (featurep 'xpm)
|
|
|
357 (setq xpm-color-symbols
|
|
|
358 (list
|
|
|
359 (purecopy '("foreground" (face-foreground 'default)))
|
|
|
360 (purecopy '("background" (face-background 'default)))
|
|
|
361 (purecopy '("backgroundToolBarColor"
|
|
|
362 (x-get-resource "backgroundToolBarColor"
|
|
|
363 "BackgroundToolBarColor" 'string)))
|
|
|
364 )))
|
|
|
365
|
|
|
366 ;;; internal routines
|
|
|
367
|
|
|
368 ;;; x-init-face-from-resources is responsible for initializing a
|
|
|
369 ;;; newly-created face from the resource database.
|
|
|
370 ;;;
|
|
|
371 ;;; When a new frame is created, it is called from `x-init-frame-faces'
|
|
|
372 ;;; called from `init-frame-faces' called from init_frame_faces()
|
|
|
373 ;;; from Fmake_frame(). In this case it is called once for each existing
|
|
|
374 ;;; face, with the newly-created frame as the argument. It then initializes
|
|
|
375 ;;; the newly-created faces on that frame.
|
|
|
376 ;;;
|
|
|
377 ;;; It's also called from `init-device-faces' and
|
|
|
378 ;;; `init-global-faces'.
|
|
|
379 ;;;
|
|
|
380 ;;; This had better not signal an error. The frame is in an intermediate
|
|
|
381 ;;; state where signalling an error or entering the debugger would likely
|
|
|
382 ;;; result in a crash.
|
|
|
383
|
|
106
|
384 (defun x-init-face-from-resources (face &optional locale set-anyway)
|
|
|
385
|
|
0
|
386 ;;
|
|
|
387 ;; These are things like "attributeForeground" instead of simply
|
|
|
388 ;; "foreground" because people tend to do things like "*foreground",
|
|
|
389 ;; which would cause all faces to be fully qualified, making faces
|
|
|
390 ;; inherit attributes in a non-useful way. So we've made them slightly
|
|
|
391 ;; less obvious to specify in order to make them work correctly in
|
|
|
392 ;; more random environments.
|
|
|
393 ;;
|
|
|
394 ;; I think these should be called "face.faceForeground" instead of
|
|
|
395 ;; "face.attributeForeground", but they're the way they are for
|
|
|
396 ;; hysterical reasons. (jwz)
|
|
|
397
|
|
106
|
398 (let* ((append (if set-anyway nil 'append))
|
|
|
399 (face-sym (face-name face))
|
|
0
|
400 (name (symbol-name face-sym))
|
|
|
401 (fn (x-get-resource-and-maybe-bogosity-check
|
|
|
402 (concat name ".attributeFont")
|
|
|
403 "Face.AttributeFont"
|
|
|
404 'string locale))
|
|
|
405 (fg (x-get-resource-and-maybe-bogosity-check
|
|
|
406 (concat name ".attributeForeground")
|
|
|
407 "Face.AttributeForeground"
|
|
|
408 'string locale))
|
|
|
409 (bg (x-get-resource-and-maybe-bogosity-check
|
|
|
410 (concat name ".attributeBackground")
|
|
|
411 "Face.AttributeBackground"
|
|
|
412 'string locale))
|
|
|
413 (bgp (x-get-resource-and-maybe-bogosity-check
|
|
|
414 (concat name ".attributeBackgroundPixmap")
|
|
|
415 "Face.AttributeBackgroundPixmap"
|
|
|
416 'string locale))
|
|
|
417 (ulp (x-get-resource-and-maybe-bogosity-check
|
|
|
418 (concat name ".attributeUnderline")
|
|
|
419 "Face.AttributeUnderline"
|
|
|
420 'boolean locale))
|
|
|
421 (stp (x-get-resource-and-maybe-bogosity-check
|
|
|
422 (concat name ".attributeStrikethru")
|
|
|
423 "Face.AttributeStrikethru"
|
|
|
424 'boolean locale))
|
|
|
425 ;; we still resource for these TTY-only resources so that
|
|
|
426 ;; you can specify resources for TTY frames/devices. This is
|
|
|
427 ;; useful when you start up your XEmacs on an X display and later
|
|
|
428 ;; open some TTY frames.
|
|
|
429 (hp (x-get-resource-and-maybe-bogosity-check
|
|
|
430 (concat name ".attributeHighlight")
|
|
|
431 "Face.AttributeHighlight"
|
|
|
432 'boolean locale))
|
|
|
433 (dp (x-get-resource-and-maybe-bogosity-check
|
|
|
434 (concat name ".attributeDim")
|
|
|
435 "Face.AttributeDim"
|
|
|
436 'boolean locale))
|
|
|
437 (bp (x-get-resource-and-maybe-bogosity-check
|
|
|
438 (concat name ".attributeBlinking")
|
|
|
439 "Face.AttributeBlinking"
|
|
|
440 'boolean locale))
|
|
|
441 (rp (x-get-resource-and-maybe-bogosity-check
|
|
|
442 (concat name ".attributeReverse")
|
|
|
443 "Face.AttributeReverse"
|
|
|
444 'boolean locale))
|
|
|
445 )
|
|
|
446
|
|
|
447 ;;
|
|
|
448 ;; If this is the default face, then any unspecified properties should
|
|
|
449 ;; be defaulted from the global properties. Can't do this for
|
|
|
450 ;; frames or devices because then, common resource specs like
|
|
|
451 ;; "*Foreground: black" will have unwanted effects.
|
|
|
452 ;;
|
|
|
453 (if (and (eq (face-name face) 'default)
|
|
|
454 (or (null locale) (eq locale 'global)))
|
|
|
455 (progn
|
|
|
456 (or fn (setq fn (x-get-resource
|
|
|
457 "font" "Font" 'string locale)))
|
|
|
458 (or fg (setq fg (x-get-resource
|
|
|
459 "foreground" "Foreground" 'string locale)))
|
|
|
460 (or bg (setq bg (x-get-resource
|
|
|
461 "background" "Background" 'string locale)))))
|
|
|
462 ;;
|
|
|
463 ;; "*cursorColor: foo" is equivalent to setting the background of the
|
|
|
464 ;; text-cursor face.
|
|
|
465 ;;
|
|
|
466 (if (and (eq (face-name face) 'text-cursor)
|
|
|
467 (or (null locale) (eq locale 'global)))
|
|
|
468 (setq bg (or (x-get-resource
|
|
|
469 "cursorColor" "CursorColor" 'string locale) bg)))
|
|
|
470 ;; #### should issue warnings? I think this should be
|
|
|
471 ;; done when the instancing actually happens, but I'm not
|
|
|
472 ;; sure how it should actually be dealt with.
|
|
|
473 (if fn
|
|
106
|
474 (set-face-font face fn locale nil append))
|
|
0
|
475 ;; Kludge-o-rooni. Set the foreground and background resources for
|
|
|
476 ;; X devices only -- otherwise things tend to get all messed up
|
|
|
477 ;; if you start up an X frame and then later create a TTY frame.
|
|
|
478 (if fg
|
|
106
|
479 (set-face-foreground face fg locale 'x append))
|
|
0
|
480 (if bg
|
|
106
|
481 (set-face-background face bg locale 'x append))
|
|
0
|
482 (if bgp
|
|
106
|
483 (set-face-background-pixmap face bgp locale nil append))
|
|
0
|
484 (if ulp
|
|
106
|
485 (set-face-underline-p face ulp locale nil append))
|
|
0
|
486 (if stp
|
|
106
|
487 (set-face-strikethru-p face stp locale nil append))
|
|
0
|
488 (if hp
|
|
106
|
489 (set-face-highlight-p face hp locale nil append))
|
|
0
|
490 (if dp
|
|
106
|
491 (set-face-dim-p face dp locale nil append))
|
|
0
|
492 (if bp
|
|
106
|
493 (set-face-blinking-p face bp locale nil append))
|
|
0
|
494 (if rp
|
|
106
|
495 (set-face-reverse-p face rp locale nil append))
|
|
0
|
496 ))
|
|
|
497
|
|
106
|
498 ;; GNU Emacs compatibility. (move to obsolete.el?)
|
|
|
499 (defalias 'make-face-x-resource-internal 'x-init-face-from-resources)
|
|
|
500
|
|
0
|
501 ;;; x-init-global-faces is responsible for ensuring that the
|
|
|
502 ;;; default face has some reasonable fallbacks if nothing else is
|
|
|
503 ;;; specified.
|
|
|
504 ;;;
|
|
|
505 (defun x-init-global-faces ()
|
|
|
506 (or (face-font 'default 'global)
|
|
|
507 (set-face-font 'default
|
|
|
508 "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*")
|
|
|
509 'global)
|
|
|
510 (or (face-foreground 'default 'global)
|
|
|
511 (set-face-foreground 'default "black" 'global 'x))
|
|
|
512 (or (face-background 'default 'global)
|
|
104
|
513 (set-face-background 'default "gray80" 'global 'x)))
|
|
0
|
514
|
|
|
515 ;;; x-init-device-faces is responsible for initializing default
|
|
|
516 ;;; values for faces on a newly created device.
|
|
|
517 ;;;
|
|
|
518 (defun x-init-device-faces (device)
|
|
|
519 ;;
|
|
|
520 ;; If the "default" face didn't have a font specified, try to pick one.
|
|
|
521 ;;
|
|
|
522 (or
|
|
|
523 (face-font-instance 'default device)
|
|
|
524 ;;
|
|
|
525 ;; No font specified in the resource database; try to cope.
|
|
|
526 ;;
|
|
|
527 ;; At first I wanted to do this by just putting a font-spec in the
|
|
|
528 ;; fallback resources passed to XtAppInitialize(), but that fails
|
|
|
529 ;; if there is an Emacs app-defaults file which doesn't specify a
|
|
|
530 ;; font: apparently the fallback resources are not consulted when
|
|
|
531 ;; there is an app-defaults file, which seems pretty bogus to me.
|
|
|
532 ;;
|
|
|
533 ;; We should also probably try "*xtDefaultFont", but I think that it
|
|
|
534 ;; might be legal to specify that as "xtDefaultFont:", that is, at
|
|
|
535 ;; top level, instead of "*xtDefaultFont:", that is, applicable to
|
|
|
536 ;; every application. `x-get-resource' can't handle that right now.
|
|
|
537 ;; Anyway, xtDefaultFont is probably variable-width.
|
|
|
538 ;;
|
|
|
539 ;; Some who have LucidaTypewriter think it's a better font than Courier,
|
|
|
540 ;; but it has the bug that there are no italic and bold italic versions.
|
|
|
541 ;; We could hair this code up to try and mix-and-match fonts to get a
|
|
|
542 ;; full complement, but really, why bother. It's just a default.
|
|
|
543 ;;
|
|
|
544 (let (new-x-font)
|
|
|
545 (setq new-x-font (or
|
|
|
546 ;;
|
|
|
547 ;; We default to looking for iso8859 fonts. Using a wildcard for the
|
|
|
548 ;; encoding would be bad, because that can cause English speakers to get
|
|
|
549 ;; Kanji fonts by default. It is safe to assume that people using a
|
|
|
550 ;; language other than English have both set $LANG, and have specified
|
|
|
551 ;; their `font' and `fontList' resources. In any event, it's better to
|
|
|
552 ;; err on the side of the English speaker in this case because they are
|
|
|
553 ;; much less likely to have encountered this problem, and are thus less
|
|
|
554 ;; likely to know what to do about it.
|
|
|
555
|
|
|
556 ;; Try for Courier. Almost everyone has that. (Does anyone not?)
|
|
|
557 (make-font-instance
|
|
|
558 "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*" device t)
|
|
|
559 (make-font-instance
|
|
|
560 "-*-courier-*-r-*-*-*-120-*-*-*-*-iso8859-*" device t)
|
|
|
561 ;; Next try for any "medium" charcell or monospaced iso8859 font.
|
|
|
562 (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-m-*-iso8859-*" device t)
|
|
|
563 (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-c-*-iso8859-*" device t)
|
|
|
564 ;; Next try for any charcell or monospaced iso8859 font.
|
|
|
565 (make-font-instance "-*-*-*-r-*-*-*-120-*-*-m-*-iso8859-*" device t)
|
|
|
566 (make-font-instance "-*-*-*-r-*-*-*-120-*-*-c-*-iso8859-*" device t)
|
|
|
567 ;; Ok, let's at least try to stay in 8859...
|
|
|
568 (make-font-instance "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*" device t)
|
|
|
569 ;; Boy, we sure are losing now. Try the above, but in any encoding.
|
|
|
570 (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-m-*-*-*" device t)
|
|
|
571 (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-c-*-*-*" device t)
|
|
|
572 (make-font-instance "-*-*-*-r-*-*-*-120-*-*-m-*-*-*" device t)
|
|
|
573 (make-font-instance "-*-*-*-r-*-*-*-120-*-*-c-*-*-*" device t)
|
|
|
574 (make-font-instance "-*-*-*-r-*-*-*-120-*-*-*-*-*-*" device t)
|
|
|
575 ;; Hello? Please?
|
|
|
576 (make-font-instance "-*-*-*-*-*-*-*-120-*-*-*-*-*-*" device t)
|
|
|
577 (make-font-instance "*" device t)
|
|
|
578 ;; if we get to here we're screwed, and faces.c will fatal()...
|
|
|
579 ))
|
|
|
580 (if (not (face-font 'default 'global))
|
|
|
581 (set-face-font 'default new-x-font)
|
|
|
582 (set-face-font 'default new-x-font device))))
|
|
|
583 ;;
|
|
|
584 ;; If the "default" face didn't have both colors specified, then pick
|
|
|
585 ;; some, taking into account whether one of the colors was specified.
|
|
|
586 ;;
|
|
|
587 (let ((fg (face-foreground-instance 'default device))
|
|
|
588 (bg (face-background-instance 'default device)))
|
|
|
589 (if (not (and fg bg))
|
|
|
590 (if (or (and fg (equal (downcase (color-instance-name fg)) "white"))
|
|
|
591 (and bg (equal (downcase (color-instance-name bg)) "black")))
|
|
|
592 (progn
|
|
|
593 (or fg (set-face-foreground 'default "white" device))
|
|
|
594 (or bg (set-face-background 'default "black" device)))
|
|
104
|
595 (or fg (set-face-foreground 'default "white" device))
|
|
|
596 (or bg (set-face-background 'default "black" device)))))
|
|
0
|
597
|
|
|
598 ;; Don't look at reverseVideo now or initialize the modeline. This
|
|
|
599 ;; is done on a per-frame basis at the appropriate time.
|
|
|
600
|
|
|
601 ;;
|
|
|
602 ;; Now let's try to pick some reasonable defaults for a few other faces.
|
|
|
603 ;; This kind of stuff should normally go on the create-frame-hook, but
|
|
|
604 ;; this way we won't be in danger of the user screwing things up by not
|
|
|
605 ;; adding hooks in a safe way.
|
|
|
606 ;;
|
|
|
607 (x-init-pointer-shape device) ; from x-mouse.el
|
|
|
608 )
|
|
|
609
|
|
|
610 ;;; This is called from `init-frame-faces', which is called from
|
|
|
611 ;;; init_frame_faces() which is called from Fmake_frame(), to perform
|
|
|
612 ;;; any device-specific initialization.
|
|
|
613 ;;;
|
|
|
614 (defun x-init-frame-faces (frame)
|
|
|
615 ;;
|
|
|
616 ;; The faces already got initialized (by init-frame-faces) from
|
|
|
617 ;; the resource database or global, non-frame faces. The default,
|
|
|
618 ;; bold, bold-italic, and italic faces (plus various other random faces)
|
|
|
619 ;; got set up then. But modeline didn't so that reverseVideo can be
|
|
|
620 ;; frame-specific.
|
|
|
621 ;;
|
|
|
622
|
|
|
623 ;;
|
|
|
624 ;; If reverseVideo was specified, swap the foreground and background
|
|
|
625 ;; of the default and modeline faces.
|
|
|
626 ;;
|
|
|
627 (cond ((car (x-get-resource "reverseVideo" "ReverseVideo" 'boolean frame))
|
|
|
628 ;; First make sure the modeline has fg and bg, inherited from the
|
|
|
629 ;; current default face - for the case where only one is specified,
|
|
|
630 ;; so that invert-face doesn't do something weird.
|
|
|
631 (or (face-foreground 'modeline frame)
|
|
|
632 (set-face-foreground 'modeline
|
|
|
633 (face-foreground-instance 'default frame)
|
|
|
634 frame))
|
|
|
635 (or (face-background 'modeline frame)
|
|
|
636 (set-face-background 'modeline
|
|
|
637 (face-background-instance 'default frame)
|
|
|
638 frame))
|
|
|
639 ;; Now invert both of them. If they end up looking the same,
|
|
|
640 ;; make-frame-initial-faces will invert the modeline again later.
|
|
|
641 (invert-face 'default frame)
|
|
|
642 (invert-face 'modeline frame)
|
|
|
643 )))
|
