cgit.sxemacs.org Git - sxemacs/blob - lisp/x-faces.el

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