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
3918
+ − 77 '(fc-font-match fc-pattern-del-size fc-pattern-get-size
+ − 78 fc-pattern-add-size fc-pattern-del-style fc-pattern-duplicate
+ − 79 fc-copy-pattern-partial fc-pattern-add-weight fc-pattern-del-weight
+ − 80 fc-try-font fc-pattern-del-slant fc-pattern-add-slant fc-name-parse
+ − 81 fc-name-unparse 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)
4021
+ − 536 (x-find-xft-font-of-size font #'(lambda (old-size) (- old-size 1.0)) device))
3094
+ − 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)
4021
+ − 553 (x-find-xft-font-of-size font #'(lambda (old-size) (+ old-size 1.0)) device))
3094
+ − 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
4215
+ − 606 ;; Ben originally coded this in 2005/01 to return a list of lists each
+ − 607 ;; containing a single string. This is apparently derived from use of
+ − 608 ;; this list in completion, but in fact `read-color-completion-table'
+ − 609 ;; already does this wrapping. So I'm changing this to return a list of
+ − 610 ;; strings as the TTY code does, and as expected by r-c-c-t.
+ − 611 ;; -- sjt 2007-10-06
+ − 612
+ − 613 ;; This function is probably also used by the GTK platform. Cf.
+ − 614 ;; gtk_color_list in src/objects-gtk.c.
2527
+ − 615 (defun x-color-list-internal ()
+ − 616 (if (boundp 'x-color-list-internal-cache)
+ − 617 x-color-list-internal-cache
+ − 618 (let ((rgb-file (locate-file "rgb.txt" x-library-search-path))
+ − 619 clist color p)
+ − 620 (if (not rgb-file)
+ − 621 ;; prevents multiple searches for rgb.txt if we can't find it
+ − 622 (setq x-color-list-internal-cache nil)
+ − 623 (with-current-buffer (get-buffer-create " *colors*")
+ − 624 (reset-buffer (current-buffer))
+ − 625 (insert-file-contents rgb-file)
+ − 626 (while (not (eobp))
+ − 627 ;; skip over comments
+ − 628 (while (looking-at "^!")
+ − 629 (end-of-line)
+ − 630 (forward-char 1))
+ − 631 (skip-chars-forward "0-9 \t")
+ − 632 (setq p (point))
+ − 633 (end-of-line)
+ − 634 (setq color (buffer-substring p (point))
4215
+ − 635 clist (cons color clist))
2527
+ − 636 ;; Ugh. If we want to be able to complete the lowercase form
+ − 637 ;; of the color name, we need to add it twice! Yuck.
+ − 638 (let ((dcase (downcase color)))
+ − 639 (or (string= dcase color)
4215
+ − 640 (push dcase clist)))
2527
+ − 641 (forward-char 1))
+ − 642 (kill-buffer (current-buffer))))
+ − 643 (setq x-color-list-internal-cache clist)
+ − 644 x-color-list-internal-cache)))
+ − 645
+ − 646
428
+ − 647 ;;; internal routines
+ − 648
+ − 649 ;;; x-init-face-from-resources is responsible for initializing a
+ − 650 ;;; newly-created face from the resource database.
+ − 651 ;;;
+ − 652 ;;; When a new frame is created, it is called from `x-init-frame-faces'
+ − 653 ;;; called from `init-frame-faces' called from init_frame_faces()
+ − 654 ;;; from Fmake_frame(). In this case it is called once for each existing
+ − 655 ;;; face, with the newly-created frame as the argument. It then initializes
+ − 656 ;;; the newly-created faces on that frame.
+ − 657 ;;;
+ − 658 ;;; It's also called from `init-device-faces' and
+ − 659 ;;; `init-global-faces'.
+ − 660 ;;;
+ − 661 ;;; This had better not signal an error. The frame is in an intermediate
+ − 662 ;;; state where signalling an error or entering the debugger would likely
+ − 663 ;;; result in a crash.
+ − 664
3918
+ − 665 ;; When we initialise a face from an X resource, note that we did so.
4194
+ − 666 ;;
+ − 667 ;; Now in specifier.el so run-time checks for it on non-X builds don't
+ − 668 ;; error.
+ − 669
+ − 670 ; (define-specifier-tag 'x-resource)
3918
+ − 671
428
+ − 672 (defun x-init-face-from-resources (face &optional locale set-anyway)
+ − 673
+ − 674 ;;
+ − 675 ;; These are things like "attributeForeground" instead of simply
+ − 676 ;; "foreground" because people tend to do things like "*foreground",
+ − 677 ;; which would cause all faces to be fully qualified, making faces
+ − 678 ;; inherit attributes in a non-useful way. So we've made them slightly
+ − 679 ;; less obvious to specify in order to make them work correctly in
+ − 680 ;; more random environments.
+ − 681 ;;
+ − 682 ;; I think these should be called "face.faceForeground" instead of
+ − 683 ;; "face.attributeForeground", but they're the way they are for
+ − 684 ;; hysterical reasons. (jwz)
+ − 685
+ − 686 (let* ((append (if set-anyway nil 'append))
+ − 687 ;; Some faces are initialized before XEmacs is dumped.
+ − 688 ;; In order for the X resources to be able to override
+ − 689 ;; those settings, such initialization always uses the
+ − 690 ;; `default' tag. We remove all specifier specs
+ − 691 ;; containing the `default' tag in the locale before
+ − 692 ;; adding new specs.
+ − 693 (tag-set '(default))
+ − 694 ;; The tag order matters here. The spec removal
+ − 695 ;; function uses the list cdrs. We want to remove (x
+ − 696 ;; default) and (default) specs, not (default x) and (x)
+ − 697 ;; specs.
+ − 698 (x-tag-set '(x default))
+ − 699 (tty-tag-set '(tty default))
3918
+ − 700 (our-tag-set '(x x-resource))
428
+ − 701 (device-class nil)
+ − 702 (face-sym (face-name face))
+ − 703 (name (symbol-name face-sym))
+ − 704 (fn (x-get-resource-and-maybe-bogosity-check
+ − 705 (concat name ".attributeFont")
+ − 706 "Face.AttributeFont"
+ − 707 'string locale))
+ − 708 (fg (x-get-resource-and-maybe-bogosity-check
+ − 709 (concat name ".attributeForeground")
+ − 710 "Face.AttributeForeground"
+ − 711 'string locale))
+ − 712 (bg (x-get-resource-and-maybe-bogosity-check
+ − 713 (concat name ".attributeBackground")
+ − 714 "Face.AttributeBackground"
+ − 715 'string locale))
+ − 716 (bgp (x-get-resource-and-maybe-bogosity-check
+ − 717 (concat name ".attributeBackgroundPixmap")
+ − 718 "Face.AttributeBackgroundPixmap"
+ − 719 'string locale))
+ − 720 (ulp (x-get-resource-and-maybe-bogosity-check
+ − 721 (concat name ".attributeUnderline")
+ − 722 "Face.AttributeUnderline"
+ − 723 'boolean locale))
+ − 724 (stp (x-get-resource-and-maybe-bogosity-check
+ − 725 (concat name ".attributeStrikethru")
+ − 726 "Face.AttributeStrikethru"
+ − 727 'boolean locale))
+ − 728 ;; we still resource for these TTY-only resources so that
+ − 729 ;; you can specify resources for TTY frames/devices. This is
+ − 730 ;; useful when you start up your XEmacs on an X display and later
+ − 731 ;; open some TTY frames.
+ − 732 (hp (x-get-resource-and-maybe-bogosity-check
+ − 733 (concat name ".attributeHighlight")
+ − 734 "Face.AttributeHighlight"
+ − 735 'boolean locale))
+ − 736 (dp (x-get-resource-and-maybe-bogosity-check
+ − 737 (concat name ".attributeDim")
+ − 738 "Face.AttributeDim"
+ − 739 'boolean locale))
+ − 740 (bp (x-get-resource-and-maybe-bogosity-check
+ − 741 (concat name ".attributeBlinking")
+ − 742 "Face.AttributeBlinking"
+ − 743 'boolean locale))
+ − 744 (rp (x-get-resource-and-maybe-bogosity-check
+ − 745 (concat name ".attributeReverse")
+ − 746 "Face.AttributeReverse"
+ − 747 'boolean locale))
+ − 748 )
+ − 749
+ − 750 (cond ((framep locale)
+ − 751 (setq device-class (device-class (frame-device locale))))
+ − 752 ((devicep locale)
+ − 753 (setq device-class (device-class locale))))
+ − 754
+ − 755 (if device-class
+ − 756 (setq tag-set (cons device-class tag-set)
+ − 757 x-tag-set (cons device-class x-tag-set)
3918
+ − 758 tty-tag-set (cons device-class tty-tag-set)
+ − 759 our-tag-set (cons device-class our-tag-set)))
428
+ − 760
+ − 761 ;;
+ − 762 ;; If this is the default face, then any unspecified properties should
+ − 763 ;; be defaulted from the global properties. Can't do this for
+ − 764 ;; frames or devices because then, common resource specs like
+ − 765 ;; "*Foreground: black" will have unwanted effects.
+ − 766 ;;
+ − 767 (if (and (or (eq (face-name face) 'default)
+ − 768 (eq (face-name face) 'gui-element))
+ − 769 (or (null locale) (eq locale 'global)))
+ − 770 (progn
+ − 771 (or fn (setq fn (x-get-resource
442
+ − 772 "font" "Font" 'string locale nil 'warn)))
428
+ − 773 (or fg (setq fg (x-get-resource
442
+ − 774 "foreground" "Foreground" 'string locale nil
+ − 775 'warn)))
428
+ − 776 (or bg (setq bg (x-get-resource
442
+ − 777 "background" "Background" 'string locale nil
+ − 778 'warn)))))
428
+ − 779 ;;
+ − 780 ;; "*cursorColor: foo" is equivalent to setting the background of the
+ − 781 ;; text-cursor face.
+ − 782 ;;
+ − 783 (if (and (eq (face-name face) 'text-cursor)
+ − 784 (or (null locale) (eq locale 'global)))
+ − 785 (setq bg (or (x-get-resource
442
+ − 786 "cursorColor" "CursorColor" 'string locale nil 'warn)
+ − 787 bg)))
428
+ − 788 ;; #### should issue warnings? I think this should be
+ − 789 ;; done when the instancing actually happens, but I'm not
+ − 790 ;; sure how it should actually be dealt with.
+ − 791 (when fn
+ − 792 (if device-class
+ − 793 ;; Always use the x-tag-set to remove specs, since we don't
+ − 794 ;; know whether the predumped face was initialized with an
+ − 795 ;; 'x tag or not.
+ − 796 (remove-specifier-specs-matching-tag-set-cdrs (face-font face)
+ − 797 locale
+ − 798 x-tag-set)
+ − 799 ;; If there's no device class then we're initializing
+ − 800 ;; globally. This means we should override global
+ − 801 ;; defaults for all X device classes.
+ − 802 (remove-specifier (face-font face) locale x-tag-set nil))
3918
+ − 803 (set-face-font face fn locale our-tag-set append)
+ − 804
3659
+ − 805 ;; And retain some of the fallbacks in the generated default face,
+ − 806 ;; since we don't want to try andale-mono's ISO-10646-1 encoding for
3918
+ − 807 ;; Amharic or Thai.
+ − 808 (when (and (specifierp (face-font face))
+ − 809 (consp (specifier-fallback (face-font face))))
+ − 810 (loop
+ − 811 for (tag-set . instantiator)
+ − 812 in (specifier-fallback (face-font face))
+ − 813 if (memq 'x-coverage-instantiator tag-set)
+ − 814 do (add-spec-list-to-specifier
+ − 815 (face-font face)
+ − 816 (list (cons (or locale 'global)
+ − 817 (list (cons tag-set instantiator))))
+ − 818 append))))
3659
+ − 819
428
+ − 820 ;; Kludge-o-rooni. Set the foreground and background resources for
+ − 821 ;; X devices only -- otherwise things tend to get all messed up
+ − 822 ;; if you start up an X frame and then later create a TTY frame.
+ − 823 (when fg
+ − 824 (if device-class
+ − 825 (remove-specifier-specs-matching-tag-set-cdrs (face-foreground face)
+ − 826 locale
+ − 827 x-tag-set)
+ − 828 (remove-specifier (face-foreground face) locale x-tag-set nil))
3918
+ − 829 (set-face-foreground face fg locale our-tag-set append))
428
+ − 830 (when bg
+ − 831 (if device-class
+ − 832 (remove-specifier-specs-matching-tag-set-cdrs (face-background face)
+ − 833 locale
+ − 834 x-tag-set)
+ − 835 (remove-specifier (face-background face) locale x-tag-set nil))
3918
+ − 836 (set-face-background face bg locale our-tag-set append))
428
+ − 837 (when bgp
+ − 838 (if device-class
+ − 839 (remove-specifier-specs-matching-tag-set-cdrs (face-background-pixmap
+ − 840 face)
+ − 841 locale
+ − 842 x-tag-set)
+ − 843 (remove-specifier (face-background-pixmap face) locale x-tag-set nil))
3918
+ − 844 (set-face-background-pixmap face bgp locale our-tag-set append))
428
+ − 845 (when ulp
+ − 846 (if device-class
+ − 847 (remove-specifier-specs-matching-tag-set-cdrs (face-property
+ − 848 face 'underline)
+ − 849 locale
+ − 850 tty-tag-set)
+ − 851 (remove-specifier (face-property face 'underline) locale
+ − 852 tty-tag-set nil))
3918
+ − 853 (set-face-underline-p face ulp locale our-tag-set append))
428
+ − 854 (when stp
+ − 855 (if device-class
+ − 856 (remove-specifier-specs-matching-tag-set-cdrs (face-property
+ − 857 face 'strikethru)
+ − 858 locale
+ − 859 tty-tag-set)
+ − 860 (remove-specifier (face-property face 'strikethru)
+ − 861 locale tty-tag-set nil))
3918
+ − 862 (set-face-strikethru-p face stp locale our-tag-set append))
428
+ − 863 (when hp
+ − 864 (if device-class
+ − 865 (remove-specifier-specs-matching-tag-set-cdrs (face-property
+ − 866 face 'highlight)
+ − 867 locale
+ − 868 tty-tag-set)
+ − 869 (remove-specifier (face-property face 'highlight)
+ − 870 locale tty-tag-set nil))
3918
+ − 871 (set-face-highlight-p face hp locale our-tag-set append))
428
+ − 872 (when dp
+ − 873 (if device-class
+ − 874 (remove-specifier-specs-matching-tag-set-cdrs (face-property
+ − 875 face 'dim)
+ − 876 locale
+ − 877 tty-tag-set)
+ − 878 (remove-specifier (face-property face 'dim) locale tty-tag-set nil))
3918
+ − 879 (set-face-dim-p face dp locale our-tag-set append))
428
+ − 880 (when bp
+ − 881 (if device-class
+ − 882 (remove-specifier-specs-matching-tag-set-cdrs (face-property
+ − 883 face 'blinking)
+ − 884 locale
+ − 885 tty-tag-set)
+ − 886 (remove-specifier (face-property face 'blinking) locale
+ − 887 tty-tag-set nil))
3918
+ − 888 (set-face-blinking-p face bp locale our-tag-set append))
428
+ − 889 (when rp
+ − 890 (if device-class
+ − 891 (remove-specifier-specs-matching-tag-set-cdrs (face-property
+ − 892 face 'reverse)
+ − 893 locale
+ − 894 tty-tag-set)
+ − 895 (remove-specifier (face-property face 'reverse) locale
+ − 896 tty-tag-set nil))
3918
+ − 897 (set-face-reverse-p face rp locale our-tag-set append))
428
+ − 898 ))
+ − 899
+ − 900 ;; GNU Emacs compatibility. (move to obsolete.el?)
+ − 901 (defalias 'make-face-x-resource-internal 'x-init-face-from-resources)
+ − 902
+ − 903 (defun remove-specifier-specs-matching-tag-set-cdrs (specifier locale tag-set)
+ − 904 (while tag-set
+ − 905 (remove-specifier specifier locale tag-set t)
+ − 906 (setq tag-set (cdr tag-set))))
+ − 907
+ − 908 ;;; x-init-global-faces is responsible for ensuring that the
+ − 909 ;;; default face has some reasonable fallbacks if nothing else is
+ − 910 ;;; specified.
+ − 911 ;;;
+ − 912 (defun x-init-global-faces ()
+ − 913 (or (face-foreground 'default 'global)
+ − 914 (set-face-foreground 'default "black" 'global '(x default)))
+ − 915 (or (face-background 'default 'global)
+ − 916 (set-face-background 'default "gray80" 'global '(x default))))
+ − 917
+ − 918 ;;; x-init-device-faces is responsible for initializing default
+ − 919 ;;; values for faces on a newly created device.
+ − 920 ;;;
+ − 921 (defun x-init-device-faces (device)
+ − 922 ;;
+ − 923 ;; If the "default" face didn't have a font specified, try to pick one.
+ − 924 ;;
872
+ − 925 ;; (or
+ − 926 ;; (face-font-instance 'default device)
+ − 927 ;;
+ − 928 ;; [[ No font specified in the resource database; try to cope. ]]
+ − 929 ;;
+ − 930 ;; NOTE: In reality, this will never happen. The fallbacks will always
+ − 931 ;; be tried, and the last fallback is "*", which should get any font. No
+ − 932 ;; need to put the same checks here as in the fallbacks. These comments
+ − 933 ;; appear to be pre-19.12. --ben
428
+ − 934
872
+ − 935 ;; [[ At first I wanted to do this by just putting a font-spec in the
+ − 936 ;; fallback resources passed to XtAppInitialize(), but that fails
+ − 937 ;; if there is an Emacs app-defaults file which doesn't specify a
+ − 938 ;; font: apparently the fallback resources are not consulted when
+ − 939 ;; there is an app-defaults file, which seems pretty bogus to me.
+ − 940 ;;
+ − 941 ;; We should also probably try "*xtDefaultFont", but I think that it
+ − 942 ;; might be legal to specify that as "xtDefaultFont:", that is, at
+ − 943 ;; top level, instead of "*xtDefaultFont:", that is, applicable to
+ − 944 ;; every application. `x-get-resource' can't handle that right now.
+ − 945 ;; Anyway, xtDefaultFont is probably variable-width.
+ − 946 ;;
+ − 947 ;; Some who have LucidaTypewriter think it's a better font than Courier,
+ − 948 ;; but it has the bug that there are no italic and bold italic versions.
+ − 949 ;; We could hair this code up to try and mix-and-match fonts to get a
+ − 950 ;; full complement, but really, why bother. It's just a default. ]]
+ − 951 ;;
+ − 952 ;; [[ We default to looking for iso8859 fonts. Using a wildcard for the
+ − 953 ;; encoding would be bad, because that can cause English speakers to get
+ − 954 ;; Kanji fonts by default. It is safe to assume that people using a
+ − 955 ;; language other than English have both set $LANG, and have specified
+ − 956 ;; their `font' and `fontList' resources. In any event, it's better to
+ − 957 ;; err on the side of the English speaker in this case because they are
+ − 958 ;; much less likely to have encountered this problem, and are thus less
+ − 959 ;; likely to know what to do about it. ]]
+ − 960
+ − 961
428
+ − 962 ;;
+ − 963 ;; If the "default" face didn't have both colors specified, then pick
+ − 964 ;; some, taking into account whether one of the colors was specified.
+ − 965 ;;
+ − 966 (let ((fg (face-foreground-instance 'default device))
+ − 967 (bg (face-background-instance 'default device)))
+ − 968 (if (not (and fg bg))
801
+ − 969 (if (or (and fg (equalp (color-instance-name fg) "white"))
+ − 970 (and bg (equalp (color-instance-name bg) "black")))
428
+ − 971 (progn
+ − 972 (or fg (set-face-foreground 'default "white" device))
+ − 973 (or bg (set-face-background 'default "black" device)))
+ − 974 (or fg (set-face-foreground 'default "white" device))
+ − 975 (or bg (set-face-background 'default "black" device)))))
+ − 976
+ − 977 ;; Don't look at reverseVideo now or initialize the modeline. This
+ − 978 ;; is done on a per-frame basis at the appropriate time.
+ − 979
+ − 980 ;;
+ − 981 ;; Now let's try to pick some reasonable defaults for a few other faces.
+ − 982 ;; This kind of stuff should normally go on the create-frame-hook, but
+ − 983 ;; this way we won't be in danger of the user screwing things up by not
+ − 984 ;; adding hooks in a safe way.
+ − 985 ;;
+ − 986 (x-init-pointer-shape device) ; from x-mouse.el
+ − 987 )
+ − 988
+ − 989 ;;; This is called from `init-frame-faces', which is called from
+ − 990 ;;; init_frame_faces() which is called from Fmake_frame(), to perform
+ − 991 ;;; any device-specific initialization.
+ − 992 ;;;
+ − 993 (defun x-init-frame-faces (frame)
+ − 994 ;;
+ − 995 ;; The faces already got initialized (by init-frame-faces) from
+ − 996 ;; the resource database or global, non-frame faces. The default,
+ − 997 ;; bold, bold-italic, and italic faces (plus various other random faces)
+ − 998 ;; got set up then. But modeline didn't so that reverseVideo can be
+ − 999 ;; frame-specific.
+ − 1000 ;;
+ − 1001
+ − 1002 ;;
+ − 1003 ;; If reverseVideo was specified, swap the foreground and background
+ − 1004 ;; of the default and modeline faces.
+ − 1005 ;;
442
+ − 1006 (cond ((car (x-get-resource "reverseVideo" "ReverseVideo" 'boolean frame
+ − 1007 nil 'warn))
428
+ − 1008 ;; First make sure the modeline has fg and bg, inherited from the
+ − 1009 ;; current default face - for the case where only one is specified,
+ − 1010 ;; so that invert-face doesn't do something weird.
+ − 1011 (or (face-foreground 'modeline frame)
+ − 1012 (set-face-foreground 'modeline
+ − 1013 (face-foreground-instance 'default frame)
+ − 1014 frame))
+ − 1015 (or (face-background 'modeline frame)
+ − 1016 (set-face-background 'modeline
+ − 1017 (face-background-instance 'default frame)
+ − 1018 frame))
+ − 1019 ;; Now invert both of them. If they end up looking the same,
+ − 1020 ;; make-frame-initial-faces will invert the modeline again later.
+ − 1021 (invert-face 'default frame)
+ − 1022 (invert-face 'modeline frame)
+ − 1023 )))
+ − 1024
+ − 1025 ;;; x-faces.el ends here