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