428
+ − 1 ;;; font.el --- New font model
502
+ − 2
+ − 3 ;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
+ − 4 ;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
2527
+ − 5 ;; Copyright (C) 2002, 2004 Ben Wing.
502
+ − 6
428
+ − 7 ;; Author: wmperry
502
+ − 8 ;; Maintainer: XEmacs Development Team
428
+ − 9 ;; Created: 1997/09/05 15:44:37
502
+ − 10 ;; Keywords: faces
428
+ − 11 ;; Version: 1.52
502
+ − 12
+ − 13 ;; XEmacs is free software; you can redistribute it and/or modify it
+ − 14 ;; under the terms of the GNU General Public License as published by
872
+ − 15 ;; the Free Software Foundation; either version 2, or (at your option)
502
+ − 16 ;; any later version.
+ − 17
+ − 18 ;; XEmacs is distributed in the hope that it will be useful, but
+ − 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ − 21 ;; General Public License for more details.
428
+ − 22
502
+ − 23 ;; You should have received a copy of the GNU General Public License
+ − 24 ;; along with XEmacs; see the file COPYING. If not, write to the Free
+ − 25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ − 26 ;; 02111-1307, USA.
+ − 27
+ − 28 ;;; Synched up with: Not in FSF
+ − 29
+ − 30 ;;; Commentary:
428
+ − 31
3094
+ − 32 ;; This file is totally bogus in the context of Emacs. Much of what it does
+ − 33 ;; is really in the provice of faces (for example all the style parameters),
+ − 34 ;; and that's the way it is in GNU Emacs.
+ − 35 ;;
+ − 36 ;; What is needed for fonts at the Lisp level is a consistent way to access
+ − 37 ;; face properties that are actually associated with fonts for some rendering
+ − 38 ;; engine, in other words, the kinds of facilities provided by fontconfig
+ − 39 ;; patterns. We just need to provide an interface to looking up, storing,
+ − 40 ;; and manipulating font specifications with certain properties. There will
+ − 41 ;; be some engine-specific stuff, like the bogosity of X11's character set
+ − 42 ;; registries.
+ − 43
502
+ − 44 ;;; Code:
+ − 45
+ − 46 (globally-declare-fboundp
2527
+ − 47 '(internal-facep fontsetp get-font-info
523
+ − 48 get-fontset-info mswindows-define-rgb-color cancel-function-timers
872
+ − 49 mswindows-font-regexp mswindows-canonicalize-font-name
+ − 50 mswindows-parse-font-style mswindows-construct-font-style
523
+ − 51 ;; #### perhaps we should rewrite font-warn to avoid the warning
+ − 52 font-warn))
502
+ − 53
+ − 54 (globally-declare-boundp
+ − 55 '(global-face-data
1346
+ − 56 x-font-regexp x-font-regexp-foundry-and-family
3094
+ − 57 fc-font-regexp
1346
+ − 58 mswindows-font-regexp))
502
+ − 59
428
+ − 60 (require 'cl)
+ − 61
+ − 62 (eval-and-compile
+ − 63 (defvar device-fonts-cache)
+ − 64 (condition-case ()
+ − 65 (require 'custom)
+ − 66 (error nil))
+ − 67 (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ − 68 nil ;; We've got what we needed
+ − 69 ;; We have the old custom-library, hack around it!
+ − 70 (defmacro defgroup (&rest args)
+ − 71 nil)
+ − 72 (defmacro defcustom (var value doc &rest args)
+ − 73 `(defvar ,var ,value ,doc))))
+ − 74
2527
+ − 75 ; delete alternate defn of try-font-name
428
+ − 76
+ − 77 (if (not (fboundp 'facep))
+ − 78 (defun facep (face)
+ − 79 "Return t if X is a face name or an internal face vector."
+ − 80 (if (not window-system)
+ − 81 nil ; FIXME if FSF ever does TTY faces
+ − 82 (and (or (internal-facep face)
+ − 83 (and (symbolp face) (assq face global-face-data)))
+ − 84 t))))
+ − 85
+ − 86 (if (not (fboundp 'set-face-property))
+ − 87 (defun set-face-property (face property value &optional locale
+ − 88 tag-set how-to-add)
+ − 89 "Change a property of FACE."
+ − 90 (and (symbolp face)
+ − 91 (put face property value))))
+ − 92
+ − 93 (if (not (fboundp 'face-property))
+ − 94 (defun face-property (face property &optional locale tag-set exact-p)
+ − 95 "Return FACE's value of the given PROPERTY."
+ − 96 (and (symbolp face) (get face property))))
+ − 97
+ − 98 (require 'disp-table)
+ − 99
+ − 100
+ − 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 102 ;;; Lots of variables / keywords for use later in the program
+ − 103 ;;; Not much should need to be modified
+ − 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3094
+ − 105 ;; #### These aren't window system mappings
428
+ − 106 (defconst font-window-system-mappings
+ − 107 '((x . (x-font-create-name x-font-create-object))
608
+ − 108 (gtk . (x-font-create-name x-font-create-object))
3094
+ − 109 ;; #### FIXME should this handle fontconfig font objects?
+ − 110 (fc . (fc-font-create-name fc-font-create-object))
428
+ − 111 (ns . (ns-font-create-name ns-font-create-object))
+ − 112 (mswindows . (mswindows-font-create-name mswindows-font-create-object))
+ − 113 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
3094
+ − 114 ;; #### what is this bogosity?
428
+ − 115 (tty . (tty-font-create-plist tty-font-create-object)))
707
+ − 116 "An assoc list mapping device types to a list of translations.
+ − 117
+ − 118 The first function creates a font name from a font descriptor object.
+ − 119 The second performs the reverse translation.")
428
+ − 120
+ − 121 (defconst ns-font-weight-mappings
+ − 122 '((:extra-light . "extralight")
+ − 123 (:light . "light")
+ − 124 (:demi-light . "demilight")
+ − 125 (:medium . "medium")
+ − 126 (:normal . "medium")
+ − 127 (:demi-bold . "demibold")
+ − 128 (:bold . "bold")
+ − 129 (:extra-bold . "extrabold"))
+ − 130 "An assoc list mapping keywords to actual NeXTstep specific
+ − 131 information to use")
+ − 132
+ − 133 (defconst x-font-weight-mappings
+ − 134 '((:extra-light . "extralight")
+ − 135 (:light . "light")
+ − 136 (:demi-light . "demilight")
+ − 137 (:demi . "demi")
+ − 138 (:book . "book")
+ − 139 (:medium . "medium")
+ − 140 (:normal . "medium")
+ − 141 (:demi-bold . "demibold")
+ − 142 (:bold . "bold")
+ − 143 (:extra-bold . "extrabold"))
+ − 144 "An assoc list mapping keywords to actual Xwindow specific strings
+ − 145 for use in the 'weight' field of an X font string.")
+ − 146
+ − 147 (defconst font-possible-weights
+ − 148 (mapcar 'car x-font-weight-mappings))
+ − 149
+ − 150 (defvar font-rgb-file nil
+ − 151 "Where the RGB file was found.")
+ − 152
+ − 153 (defvar font-maximum-slippage "1pt"
+ − 154 "How much a font is allowed to vary from the desired size.")
+ − 155
707
+ − 156 ;; Canonical (internal) sizes are in points.
428
+ − 157
3094
+ − 158 ;; Property keywords: :family :style :size :registry :encoding :weight
+ − 159 ;; Weight keywords: :extra-light :light :demi-light :medium
+ − 160 ;; :normal :demi-bold :bold :extra-bold
+ − 161 ;; See GNU Emacs 21.4 for more properties and keywords we should support
428
+ − 162
+ − 163 (defvar font-style-keywords nil)
+ − 164
502
+ − 165 (defun set-font-family (fontobj family)
428
+ − 166 (aset fontobj 1 family))
+ − 167
502
+ − 168 (defun set-font-weight (fontobj weight)
428
+ − 169 (aset fontobj 3 weight))
+ − 170
502
+ − 171 (defun set-font-style (fontobj style)
428
+ − 172 (aset fontobj 5 style))
+ − 173
502
+ − 174 (defun set-font-size (fontobj size)
428
+ − 175 (aset fontobj 7 size))
+ − 176
502
+ − 177 (defun set-font-registry (fontobj reg)
428
+ − 178 (aset fontobj 9 reg))
+ − 179
502
+ − 180 (defun set-font-encoding (fontobj enc)
428
+ − 181 (aset fontobj 11 enc))
+ − 182
502
+ − 183 (defun font-family (fontobj)
428
+ − 184 (aref fontobj 1))
+ − 185
502
+ − 186 (defun font-weight (fontobj)
428
+ − 187 (aref fontobj 3))
+ − 188
502
+ − 189 (defun font-style (fontobj)
428
+ − 190 (aref fontobj 5))
+ − 191
502
+ − 192 (defun font-size (fontobj)
428
+ − 193 (aref fontobj 7))
+ − 194
502
+ − 195 (defun font-registry (fontobj)
428
+ − 196 (aref fontobj 9))
+ − 197
502
+ − 198 (defun font-encoding (fontobj)
428
+ − 199 (aref fontobj 11))
+ − 200
+ − 201 (eval-when-compile
+ − 202 (defmacro define-new-mask (attr mask)
+ − 203 `(progn
+ − 204 (setq font-style-keywords
+ − 205 (cons (cons (quote ,attr)
+ − 206 (cons
+ − 207 (quote ,(intern (format "set-font-%s-p" attr)))
+ − 208 (quote ,(intern (format "font-%s-p" attr)))))
+ − 209 font-style-keywords))
502
+ − 210 (defconst ,(intern (format "font-%s-mask" attr)) (lsh 1 ,mask)
428
+ − 211 ,(format
+ − 212 "Bitmask for whether a font is to be rendered in %s or not."
+ − 213 attr))
+ − 214 (defun ,(intern (format "font-%s-p" attr)) (fontobj)
+ − 215 ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr)
502
+ − 216 (if (/= 0 (logand (font-style fontobj)
428
+ − 217 ,(intern (format "font-%s-mask" attr))))
+ − 218 t
+ − 219 nil))
+ − 220 (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val)
+ − 221 ,(format "Set whether FONTOBJ will be renderd in `%s' or not."
+ − 222 attr)
+ − 223 (cond
+ − 224 (val
502
+ − 225 (set-font-style fontobj (logior (font-style fontobj)
+ − 226 ,(intern
+ − 227 (format "font-%s-mask" attr)))))
428
+ − 228 ((,(intern (format "font-%s-p" attr)) fontobj)
+ − 229 (set-font-style fontobj (- (font-style fontobj)
+ − 230 ,(intern
+ − 231 (format "font-%s-mask" attr)))))))
+ − 232 )))
+ − 233
523
+ − 234 (define-new-mask bold 1)
+ − 235 (define-new-mask italic 2)
+ − 236 (define-new-mask oblique 3)
+ − 237 (define-new-mask dim 4)
+ − 238 (define-new-mask underline 5)
+ − 239 (define-new-mask overline 6)
+ − 240 (define-new-mask linethrough 7)
+ − 241 (define-new-mask strikethru 8)
+ − 242 (define-new-mask reverse 9)
+ − 243 (define-new-mask blink 10)
+ − 244 (define-new-mask smallcaps 11)
+ − 245 (define-new-mask bigcaps 12)
+ − 246 (define-new-mask dropcaps 13)
428
+ − 247
+ − 248 (defvar font-caps-display-table
+ − 249 (let ((table (make-display-table))
+ − 250 (i 0))
+ − 251 ;; Standard ASCII characters
+ − 252 (while (< i 26)
+ − 253 (aset table (+ i ?a) (+ i ?A))
+ − 254 (setq i (1+ i)))
+ − 255 ;; Now ISO translations
3094
+ − 256 ;; #### FIXME what's this for??
428
+ − 257 (setq i 224)
+ − 258 (while (< i 247) ;; Agrave - Ouml
+ − 259 (aset table i (- i 32))
+ − 260 (setq i (1+ i)))
+ − 261 (setq i 248)
+ − 262 (while (< i 255) ;; Oslash - Thorn
+ − 263 (aset table i (- i 32))
+ − 264 (setq i (1+ i)))
+ − 265 table))
+ − 266
+ − 267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 268 ;;; Utility functions
+ − 269 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3094
+ − 270 ;; #### unused?
+ − 271 ; (defun set-font-style-by-keywords (fontobj styles)
+ − 272 ; (make-local-variable 'font-func)
+ − 273 ; (declare (special font-func))
+ − 274 ; (if (listp styles)
+ − 275 ; (while styles
+ − 276 ; (setq font-func (car-safe (cdr-safe (assq (car styles)
+ − 277 ; font-style-keywords)))
+ − 278 ; styles (cdr styles))
+ − 279 ; (and (fboundp font-func) (funcall font-func fontobj t)))
+ − 280 ; (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
+ − 281 ; (and (fboundp font-func) (funcall font-func fontobj t))))
428
+ − 282
3094
+ − 283 ;; #### unused?
+ − 284 ; (defun font-properties-from-style (fontobj)
+ − 285 ; (let ((todo font-style-keywords)
+ − 286 ; type func retval)
+ − 287 ; (while todo
+ − 288 ; (setq func (cdr (cdr (car todo)))
+ − 289 ; type (car (pop todo)))
+ − 290 ; (if (funcall func fontobj)
+ − 291 ; (setq retval (cons type retval))))
+ − 292 ; retval))
428
+ − 293
3094
+ − 294 ;; #### only used in this file; maybe there's a cl.el function?
428
+ − 295 (defun font-unique (list)
+ − 296 (let ((retval)
+ − 297 (cur))
+ − 298 (while list
+ − 299 (setq cur (car list)
+ − 300 list (cdr list))
+ − 301 (if (member cur retval)
+ − 302 nil
+ − 303 (setq retval (cons cur retval))))
+ − 304 (nreverse retval)))
+ − 305
+ − 306 (defun font-higher-weight (w1 w2)
+ − 307 (let ((index1 (length (memq w1 font-possible-weights)))
+ − 308 (index2 (length (memq w2 font-possible-weights))))
+ − 309 (cond
+ − 310 ((<= index1 index2)
+ − 311 (or w1 w2))
+ − 312 ((not w2)
+ − 313 w1)
+ − 314 (t
+ − 315 w2))))
+ − 316
+ − 317 (defun font-spatial-to-canonical (spec &optional device)
707
+ − 318 "Convert SPEC (in inches, millimeters, points, picas, or pixels) into points.
+ − 319
+ − 320 Canonical sizes are in points. If SPEC is null, nil is returned. If SPEC is
+ − 321 a number, it is interpreted as the desired point size and returned unchanged.
+ − 322 Otherwise SPEC must be a string consisting of a number and an optional type.
+ − 323 The type may be the strings \"px\", \"pix\", or \"pixel\" (pixels), \"pt\" or
2685
+ − 324 \"point\" (points), \"pa\" or \"pica\" (picas), \"in\" or \"inch\" (inches),
+ − 325 \"cm\" (centimeters), or \"mm\" (millimeters).
707
+ − 326
+ − 327 1 in = 2.54 cm = 6 pa = 25.4 mm = 72 pt. Pixel size is device-dependent."
428
+ − 328 (cond
+ − 329 ((numberp spec)
+ − 330 spec)
+ − 331 ((null spec)
+ − 332 nil)
+ − 333 (t
+ − 334 (let ((num nil)
+ − 335 (type nil)
+ − 336 ;; If for any reason we get null for any of this, default
+ − 337 ;; to 1024x768 resolution on a 17" screen
+ − 338 (pix-width (float (or (device-pixel-width device) 1024)))
+ − 339 (mm-width (float (or (device-mm-width device) 293)))
+ − 340 (retval nil))
+ − 341 (cond
3094
+ − 342 ;; #### this is pretty bogus and should probably be made gone
+ − 343 ;; or supported at a higher level
428
+ − 344 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee!
+ − 345 (let ((math-func (intern (match-string 1 spec)))
+ − 346 (other (font-spatial-to-canonical
+ − 347 (substring spec (match-end 0) nil)))
+ − 348 (default (font-spatial-to-canonical
+ − 349 (font-default-size-for-device device))))
+ − 350 (if (fboundp math-func)
+ − 351 (setq type "px"
+ − 352 spec (int-to-string (funcall math-func default other)))
+ − 353 (setq type "px"
+ − 354 spec (int-to-string other)))))
+ − 355 ((string-match "[^0-9.]+$" spec)
+ − 356 (setq type (substring spec (match-beginning 0))
+ − 357 spec (substring spec 0 (match-beginning 0))))
+ − 358 (t
+ − 359 (setq type "px"
+ − 360 spec spec)))
+ − 361 (setq num (string-to-number spec))
+ − 362 (cond
+ − 363 ((member type '("pixel" "px" "pix"))
2685
+ − 364 (setq retval (* num (/ mm-width pix-width) (/ 72.0 25.4))))
428
+ − 365 ((member type '("point" "pt"))
+ − 366 (setq retval num))
+ − 367 ((member type '("pica" "pa"))
+ − 368 (setq retval (* num 12.0)))
+ − 369 ((member type '("inch" "in"))
+ − 370 (setq retval (* num 72.0)))
+ − 371 ((string= type "mm")
+ − 372 (setq retval (* num (/ 72.0 25.4))))
+ − 373 ((string= type "cm")
3094
+ − 374 (setq retval (* num (/ 72.0 2.54))))
428
+ − 375 (t
+ − 376 (setq retval num))
+ − 377 )
+ − 378 retval))))
+ − 379
+ − 380
+ − 381 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 382 ;;; The main interface routines - constructors and accessor functions
+ − 383 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 384 (defun make-font (&rest args)
+ − 385 (vector :family
+ − 386 (if (stringp (plist-get args :family))
+ − 387 (list (plist-get args :family))
+ − 388 (plist-get args :family))
+ − 389 :weight
+ − 390 (plist-get args :weight)
+ − 391 :style
+ − 392 (if (numberp (plist-get args :style))
+ − 393 (plist-get args :style)
+ − 394 0)
+ − 395 :size
+ − 396 (plist-get args :size)
+ − 397 :registry
+ − 398 (plist-get args :registry)
+ − 399 :encoding
+ − 400 (plist-get args :encoding)))
+ − 401
+ − 402 (defun font-create-name (fontobj &optional device)
707
+ − 403 "Return a font name constructed from FONTOBJ, appropriate for DEVICE."
428
+ − 404 (let* ((type (device-type device))
+ − 405 (func (car (cdr-safe (assq type font-window-system-mappings)))))
+ − 406 (and func (fboundp func) (funcall func fontobj device))))
+ − 407
+ − 408 ;;;###autoload
+ − 409 (defun font-create-object (fontname &optional device)
707
+ − 410 "Return a font descriptor object for FONTNAME, appropriate for DEVICE."
428
+ − 411 (let* ((type (device-type device))
+ − 412 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
+ − 413 (and func (fboundp func) (funcall func fontname device))))
+ − 414
+ − 415 (defun font-combine-fonts-internal (fontobj-1 fontobj-2)
+ − 416 (let ((retval (make-font))
+ − 417 (size-1 (and (font-size fontobj-1)
+ − 418 (font-spatial-to-canonical (font-size fontobj-1))))
+ − 419 (size-2 (and (font-size fontobj-2)
+ − 420 (font-spatial-to-canonical (font-size fontobj-2)))))
+ − 421 (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
+ − 422 (font-weight fontobj-2)))
+ − 423 (set-font-family retval (font-unique (append (font-family fontobj-1)
+ − 424 (font-family fontobj-2))))
502
+ − 425 (set-font-style retval (logior (font-style fontobj-1)
+ − 426 (font-style fontobj-2)))
428
+ − 427 (set-font-registry retval (or (font-registry fontobj-1)
+ − 428 (font-registry fontobj-2)))
+ − 429 (set-font-encoding retval (or (font-encoding fontobj-1)
+ − 430 (font-encoding fontobj-2)))
+ − 431 (set-font-size retval (cond
+ − 432 ((and size-1 size-2 (>= size-2 size-1))
+ − 433 (font-size fontobj-2))
+ − 434 ((and size-1 size-2)
+ − 435 (font-size fontobj-1))
+ − 436 (size-1
+ − 437 (font-size fontobj-1))
+ − 438 (size-2
+ − 439 (font-size fontobj-2))
+ − 440 (t nil)))
+ − 441
+ − 442 retval))
+ − 443
+ − 444 (defun font-combine-fonts (&rest args)
+ − 445 (cond
+ − 446 ((null args)
+ − 447 (error "Wrong number of arguments to font-combine-fonts"))
+ − 448 ((= (length args) 1)
+ − 449 (car args))
+ − 450 (t
+ − 451 (let ((retval (font-combine-fonts-internal (nth 0 args) (nth 1 args))))
+ − 452 (setq args (cdr (cdr args)))
+ − 453 (while args
+ − 454 (setq retval (font-combine-fonts-internal retval (car args))
+ − 455 args (cdr args)))
+ − 456 retval))))
+ − 457
3094
+ − 458 (defvar font-default-cache nil)
+ − 459
+ − 460 ;;;###autoload
+ − 461 (defun font-default-font-for-device (&optional device)
+ − 462 (or device (setq device (selected-device)))
+ − 463 (font-truename
+ − 464 (make-font-specifier
+ − 465 (face-font-name 'default device))))
+ − 466
+ − 467 ;;;###autoload
+ − 468 (defun font-default-object-for-device (&optional device)
+ − 469 (let ((font (font-default-font-for-device device)))
+ − 470 (or (cdr-safe (assoc font font-default-cache))
+ − 471 (let ((object (font-create-object font)))
+ − 472 (push (cons font object) font-default-cache)
+ − 473 object))))
+ − 474
+ − 475 ;;;###autoload
+ − 476 (defun font-default-family-for-device (&optional device)
+ − 477 (font-family (font-default-object-for-device (or device (selected-device)))))
+ − 478
+ − 479 ;;;###autoload
+ − 480 (defun font-default-registry-for-device (&optional device)
+ − 481 (font-registry (font-default-object-for-device (or device (selected-device)))))
+ − 482
+ − 483 ;;;###autoload
+ − 484 (defun font-default-encoding-for-device (&optional device)
+ − 485 (font-encoding (font-default-object-for-device (or device (selected-device)))))
+ − 486
+ − 487 ;;;###autoload
+ − 488 (defun font-default-size-for-device (&optional device)
+ − 489 ;; face-height isn't the right thing (always 1 pixel too high?)
+ − 490 ;; (if font-running-xemacs
+ − 491 ;; (format "%dpx" (face-height 'default device))
+ − 492 (font-size (font-default-object-for-device (or device (selected-device)))))
+ − 493
428
+ − 494
+ − 495 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 496 ;;; The window-system dependent code (TTY-style)
+ − 497 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 498 (defun tty-font-create-object (fontname &optional device)
707
+ − 499 "Return a font descriptor object for FONTNAME, appropriate for TTY devices."
428
+ − 500 (make-font :size "12pt"))
+ − 501
+ − 502 (defun tty-font-create-plist (fontobj &optional device)
707
+ − 503 "Return a font name constructed from FONTOBJ, appropriate for TTY devices."
428
+ − 504 (list
+ − 505 (cons 'underline (font-underline-p fontobj))
+ − 506 (cons 'highlight (if (or (font-bold-p fontobj)
+ − 507 (memq (font-weight fontobj) '(:bold :demi-bold)))
+ − 508 t))
+ − 509 (cons 'dim (font-dim-p fontobj))
+ − 510 (cons 'blinking (font-blink-p fontobj))
+ − 511 (cons 'reverse (font-reverse-p fontobj))))
+ − 512
+ − 513
+ − 514 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 515 ;;; The window-system dependent code (X-style)
+ − 516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3094
+ − 517 (defvar font-x-font-regexp (when (and (boundp 'x-font-regexp)
+ − 518 x-font-regexp)
428
+ − 519 (let
+ − 520 ((- "[-?]")
+ − 521 (foundry "[^-]*")
+ − 522 (family "[^-]*")
502
+ − 523 ;(weight "\\(bold\\|demibold\\|medium\\|black\\)")
428
+ − 524 (weight\? "\\([^-]*\\)")
502
+ − 525 ;(slant "\\([ior]\\)")
428
+ − 526 (slant\? "\\([^-]?\\)")
+ − 527 (swidth "\\([^-]*\\)")
+ − 528 (adstyle "\\([^-]*\\)")
+ − 529 (pixelsize "\\(\\*\\|[0-9]+\\)")
+ − 530 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)")
+ − 531 (resx "\\([*0]\\|[0-9][0-9]+\\)")
+ − 532 (resy "\\([*0]\\|[0-9][0-9]+\\)")
+ − 533 (spacing "[cmp?*]")
+ − 534 (avgwidth "\\(\\*\\|[0-9]+\\)")
+ − 535 (registry "[^-]*")
+ − 536 (encoding "[^-]+")
+ − 537 )
+ − 538 (concat "\\`\\*?[-?*]"
+ − 539 foundry - family - weight\? - slant\? - swidth - adstyle -
+ − 540 pixelsize - pointsize - resx - resy - spacing - avgwidth -
+ − 541 registry - encoding "\\'"
+ − 542 ))))
+ − 543
+ − 544 (defvar font-x-registry-and-encoding-regexp
3094
+ − 545 (when (and (boundp 'x-font-regexp-registry-and-encoding)
+ − 546 (symbol-value 'x-font-regexp-registry-and-encoding))
+ − 547 (let ((- "[-?]")
+ − 548 (registry "[^-]*")
+ − 549 (encoding "[^-]+"))
+ − 550 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
428
+ − 551
+ − 552 (defvar font-x-family-mappings
+ − 553 '(
+ − 554 ("serif" . ("new century schoolbook"
+ − 555 "utopia"
+ − 556 "charter"
+ − 557 "times"
+ − 558 "lucidabright"
+ − 559 "garamond"
+ − 560 "palatino"
+ − 561 "times new roman"
+ − 562 "baskerville"
+ − 563 "bookman"
+ − 564 "bodoni"
+ − 565 "computer modern"
+ − 566 "rockwell"
+ − 567 ))
+ − 568 ("sans-serif" . ("lucida"
+ − 569 "helvetica"
+ − 570 "gills-sans"
+ − 571 "avant-garde"
+ − 572 "univers"
+ − 573 "optima"))
+ − 574 ("elfin" . ("tymes"))
+ − 575 ("monospace" . ("courier"
+ − 576 "fixed"
+ − 577 "lucidatypewriter"
+ − 578 "clean"
+ − 579 "terminal"))
+ − 580 ("cursive" . ("sirene"
+ − 581 "zapf chancery"))
+ − 582 )
+ − 583 "A list of font family mappings on X devices.")
+ − 584
+ − 585 (defun x-font-create-object (fontname &optional device)
707
+ − 586 "Return a font descriptor object for FONTNAME, appropriate for X devices."
428
+ − 587 (let ((case-fold-search t))
+ − 588 (if (or (not (stringp fontname))
+ − 589 (not (string-match font-x-font-regexp fontname)))
+ − 590 (make-font)
+ − 591 (let ((family nil)
+ − 592 (size nil)
+ − 593 (weight (match-string 1 fontname))
+ − 594 (slant (match-string 2 fontname))
+ − 595 (swidth (match-string 3 fontname))
+ − 596 (adstyle (match-string 4 fontname))
+ − 597 (pxsize (match-string 5 fontname))
+ − 598 (ptsize (match-string 6 fontname))
+ − 599 (retval nil)
+ − 600 (case-fold-search t)
+ − 601 )
+ − 602 (if (not (string-match x-font-regexp-foundry-and-family fontname))
+ − 603 nil
+ − 604 (setq family (list (downcase (match-string 1 fontname)))))
+ − 605 (if (string= "*" weight) (setq weight nil))
+ − 606 (if (string= "*" slant) (setq slant nil))
+ − 607 (if (string= "*" swidth) (setq swidth nil))
+ − 608 (if (string= "*" adstyle) (setq adstyle nil))
+ − 609 (if (string= "*" pxsize) (setq pxsize nil))
+ − 610 (if (string= "*" ptsize) (setq ptsize nil))
+ − 611 (if ptsize (setq size (/ (string-to-int ptsize) 10)))
+ − 612 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
+ − 613 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
+ − 614 (if (and adstyle (not (equal adstyle "")))
+ − 615 (setq family (append family (list (downcase adstyle)))))
+ − 616 (setq retval (make-font :family family
+ − 617 :weight weight
+ − 618 :size size))
+ − 619 (set-font-bold-p retval (eq :bold weight))
+ − 620 (cond
+ − 621 ((null slant) nil)
+ − 622 ((member slant '("i" "I"))
+ − 623 (set-font-italic-p retval t))
+ − 624 ((member slant '("o" "O"))
+ − 625 (set-font-oblique-p retval t)))
+ − 626 (when (string-match font-x-registry-and-encoding-regexp fontname)
+ − 627 (set-font-registry retval (match-string 1 fontname))
+ − 628 (set-font-encoding retval (match-string 2 fontname)))
+ − 629 retval))))
+ − 630
+ − 631 (defun x-font-families-for-device (&optional device no-resetp)
+ − 632 (ignore-errors (require 'x-font-menu))
+ − 633 (or device (setq device (selected-device)))
+ − 634 (if (boundp 'device-fonts-cache)
+ − 635 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
+ − 636 (if (and (not menu) (not no-resetp))
+ − 637 (progn
+ − 638 (reset-device-font-menus device)
+ − 639 (x-font-families-for-device device t))
+ − 640 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
+ − 641 (aref menu 0)))
+ − 642 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
+ − 643 (aref menu 1))))
+ − 644 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
+ − 645 (cons "monospace" (mapcar 'car font-x-family-mappings))))
+ − 646
+ − 647 (defun x-font-create-name (fontobj &optional device)
707
+ − 648 "Return a font name constructed from FONTOBJ, appropriate for X devices."
428
+ − 649 (if (and (not (or (font-family fontobj)
+ − 650 (font-weight fontobj)
+ − 651 (font-size fontobj)
+ − 652 (font-registry fontobj)
+ − 653 (font-encoding fontobj)))
+ − 654 (= (font-style fontobj) 0))
+ − 655 (face-font 'default)
+ − 656 (or device (setq device (selected-device)))
+ − 657 (let* ((default (font-default-object-for-device device))
+ − 658 (family (or (font-family fontobj)
+ − 659 (font-family default)
+ − 660 (x-font-families-for-device device)))
+ − 661 (weight (or (font-weight fontobj) :medium))
3094
+ − 662 (size (or (font-size fontobj)
428
+ − 663 (font-size default)))
+ − 664 (registry (or (font-registry fontobj)
+ − 665 (font-registry default)
+ − 666 "*"))
+ − 667 (encoding (or (font-encoding fontobj)
+ − 668 (font-encoding default)
+ − 669 "*")))
+ − 670 (if (stringp family)
+ − 671 (setq family (list family)))
+ − 672 (setq weight (font-higher-weight weight
+ − 673 (and (font-bold-p fontobj) :bold)))
+ − 674 (if (stringp size)
+ − 675 (setq size (truncate (font-spatial-to-canonical size device))))
+ − 676 (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*"))
+ − 677 (let ((done nil) ; Did we find a good font yet?
+ − 678 (font-name nil) ; font name we are currently checking
+ − 679 (cur-family nil) ; current family we are checking
+ − 680 )
+ − 681 (while (and family (not done))
+ − 682 (setq cur-family (car family)
+ − 683 family (cdr family))
+ − 684 (if (assoc cur-family font-x-family-mappings)
+ − 685 ;; If the family name is an alias as defined by
+ − 686 ;; font-x-family-mappings, then append those families
+ − 687 ;; to the front of 'family' and continue in the loop.
+ − 688 (setq family (append
+ − 689 (cdr-safe (assoc cur-family
+ − 690 font-x-family-mappings))
+ − 691 family))
+ − 692 ;; Not an alias for a list of fonts, so we just check it.
+ − 693 ;; First, convert all '-' to spaces so that we don't screw up
+ − 694 ;; the oh-so wonderful X font model. Wheee.
+ − 695 (let ((x (length cur-family)))
+ − 696 (while (> x 0)
+ − 697 (if (= ?- (aref cur-family (1- x)))
+ − 698 (aset cur-family (1- x) ? ))
+ − 699 (setq x (1- x))))
+ − 700 ;; We treat oblique and italic as equivalent. Don't ask.
+ − 701 (let ((slants '("o" "i")))
+ − 702 (while (and slants (not done))
+ − 703 (setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s"
+ − 704 cur-family weight
+ − 705 (if (or (font-italic-p fontobj)
+ − 706 (font-oblique-p fontobj))
+ − 707 (car slants)
+ − 708 "r")
+ − 709 (if size
+ − 710 (int-to-string (* 10 size)) "*")
+ − 711 registry
+ − 712 encoding
+ − 713 )
+ − 714 slants (cdr slants)
+ − 715 done (try-font-name font-name device))))))
+ − 716 (if done font-name)))))
+ − 717
+ − 718
3094
+ − 719 ;;; Cache building code
+ − 720 ;;;###autoload
+ − 721 (defun x-font-build-cache (&optional device)
+ − 722 (let ((hash-table (make-hash-table :test 'equal :size 15))
+ − 723 (fonts (mapcar 'x-font-create-object
+ − 724 (font-list "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
+ − 725 (plist nil)
+ − 726 (cur nil))
+ − 727 (while fonts
+ − 728 (setq cur (car fonts)
+ − 729 fonts (cdr fonts)
+ − 730 plist (cl-gethash (car (font-family cur)) hash-table))
+ − 731 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
+ − 732 (setq plist (plist-put plist 'weights (cons (font-weight cur)
+ − 733 (plist-get plist 'weights)))))
+ − 734 (if (not (member (font-size cur) (plist-get plist 'sizes)))
+ − 735 (setq plist (plist-put plist 'sizes (cons (font-size cur)
+ − 736 (plist-get plist 'sizes)))))
+ − 737 (if (and (font-oblique-p cur)
+ − 738 (not (memq 'oblique (plist-get plist 'styles))))
+ − 739 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
+ − 740 (if (and (font-italic-p cur)
+ − 741 (not (memq 'italic (plist-get plist 'styles))))
+ − 742 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
+ − 743 (cl-puthash (car (font-family cur)) plist hash-table))
+ − 744 hash-table))
+ − 745
+ − 746
+ − 747 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 748 ;;; The rendering engine-dependent code (Xft-style)
+ − 749 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 750
+ − 751 ;;; #### FIXME actually, this section should be fc-*, right?
+ − 752
+ − 753 (defvar font-xft-font-regexp
+ − 754 ;; #### FIXME what the fuck?!?
+ − 755 (when (and (boundp 'xft-font-regexp) xft-font-regexp)
+ − 756 (concat "\\`"
+ − 757 "[^:-]*" ; optional foundry and family
+ − 758 ; incorrect, escaping exists
+ − 759 "\\(-[0-9]*\\(\\.[0-9]*\\)?\\)?" ; optional size (points)
+ − 760 "\\(:[^:]*\\)*" ; optional properties
+ − 761 ; not necessarily key=value!!
+ − 762 "\\'"
+ − 763 )))
+ − 764
+ − 765 (defvar font-xft-family-mappings
+ − 766 ;; #### FIXME this shouldn't be needed or used for Xft
+ − 767 '(("serif" . ("new century schoolbook"
+ − 768 "utopia"
+ − 769 "charter"
+ − 770 "times"
+ − 771 "lucidabright"
+ − 772 "garamond"
+ − 773 "palatino"
+ − 774 "times new roman"
+ − 775 "baskerville"
+ − 776 "bookman"
+ − 777 "bodoni"
+ − 778 "computer modern"
+ − 779 "rockwell"
+ − 780 ))
+ − 781 ("sans-serif" . ("lucida"
+ − 782 "helvetica"
+ − 783 "gills-sans"
+ − 784 "avant-garde"
+ − 785 "univers"
+ − 786 "optima"))
+ − 787 ("elfin" . ("tymes"))
+ − 788 ("monospace" . ("courier"
+ − 789 "fixed"
+ − 790 "lucidatypewriter"
+ − 791 "clean"
+ − 792 "terminal"))
+ − 793 ("cursive" . ("sirene"
+ − 794 "zapf chancery"))
+ − 795 )
+ − 796 "A list of font family mappings on Xft devices.")
+ − 797
+ − 798 (defun xft-font-create-object (fontname &optional device)
3360
+ − 799 "Return a font descriptor object for FONTNAME, appropriate for Xft.
+ − 800
+ − 801 Optional DEVICE defaults to `default-x-device'."
3094
+ − 802 (let* ((name fontname)
+ − 803 (device (or device (default-x-device)))
3360
+ − 804 (pattern (fc-font-match device (fc-name-parse name)))
3094
+ − 805 (font-obj (make-font))
+ − 806 (family (fc-pattern-get-family pattern 0))
+ − 807 (size (fc-pattern-get-size pattern 0))
+ − 808 (weight (fc-pattern-get-weight pattern 0)))
+ − 809 (set-font-family font-obj
+ − 810 (and (not (equal family 'fc-result-no-match))
+ − 811 family))
+ − 812 (set-font-size font-obj
+ − 813 (and (not (equal size 'fc-result-no-match))
+ − 814 size))
+ − 815 (set-font-weight font-obj
+ − 816 (and (not (equal weight 'fc-result-no-match))
+ − 817 (fc-font-weight-translate-from-constant weight)))
+ − 818 font-obj))
+ − 819
+ − 820 ;; #### FIXME Xft fonts are not defined by the device.
+ − 821 ;; ... Does that mean the whole model here is bogus?
+ − 822 (defun xft-font-families-for-device (&optional device no-resetp)
+ − 823 (ignore-errors (require 'x-font-menu)) ; #### FIXME xft-font-menu?
+ − 824 (or device (setq device (selected-device)))
+ − 825 (if (boundp 'device-fonts-cache) ; #### FIXME does this make sense?
+ − 826 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
+ − 827 (if (and (not menu) (not no-resetp))
+ − 828 (progn
+ − 829 (reset-device-font-menus device)
+ − 830 (xft-font-families-for-device device t))
+ − 831 ;; #### FIXME clearly bogus for Xft
+ − 832 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
+ − 833 (aref menu 0)))
+ − 834 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
+ − 835 (aref menu 1))))
+ − 836 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
+ − 837 ;; #### FIXME clearly bogus for Xft
+ − 838 (cons "monospace" (mapcar 'car font-xft-family-mappings))))
+ − 839
+ − 840 (defun xft-font-create-name (fontobj &optional device)
+ − 841 (let* ((pattern (make-fc-pattern)))
+ − 842 (if (font-family fontobj)
+ − 843 (fc-pattern-add-family pattern (font-family fontobj)))
+ − 844 (if (font-size fontobj)
+ − 845 (fc-pattern-add-size pattern (font-size fontobj)))
+ − 846 (fc-name-unparse pattern)))
+ − 847
+ − 848
428
+ − 849 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 850 ;;; The window-system dependent code (NS-style)
+ − 851 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 852 (defun ns-font-families-for-device (&optional device no-resetp)
+ − 853 ;; For right now, assume we are going to have the same storage for
+ − 854 ;; device fonts for NS as we do for X. Is this a valid assumption?
+ − 855 (or device (setq device (selected-device)))
+ − 856 (if (boundp 'device-fonts-cache)
+ − 857 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
+ − 858 (if (and (not menu) (not no-resetp))
+ − 859 (progn
+ − 860 (reset-device-font-menus device)
+ − 861 (ns-font-families-for-device device t))
+ − 862 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
+ − 863 (aref menu 0)))
+ − 864 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
+ − 865 (aref menu 1))))
+ − 866 (sort (font-unique (nconc scaled normal)) 'string-lessp))))))
+ − 867
+ − 868 (defun ns-font-create-name (fontobj &optional device)
707
+ − 869 "Return a font name constructed from FONTOBJ, appropriate for NextSTEP devices."
428
+ − 870 (let ((family (or (font-family fontobj)
+ − 871 (ns-font-families-for-device device)))
+ − 872 (weight (or (font-weight fontobj) :medium))
+ − 873 (style (or (font-style fontobj) (list :normal)))
502
+ − 874 (size (font-size fontobj)))
428
+ − 875 ;; Create a font, wow!
+ − 876 (if (stringp family)
+ − 877 (setq family (list family)))
+ − 878 (if (or (symbolp style) (numberp style))
+ − 879 (setq style (list style)))
+ − 880 (setq weight (font-higher-weight weight (car-safe (memq :bold style))))
+ − 881 (if (stringp size)
+ − 882 (setq size (font-spatial-to-canonical size device)))
+ − 883 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings))
+ − 884 "medium"))
+ − 885 (let ((done nil) ; Did we find a good font yet?
+ − 886 (font-name nil) ; font name we are currently checking
+ − 887 (cur-family nil) ; current family we are checking
+ − 888 )
+ − 889 (while (and family (not done))
+ − 890 (setq cur-family (car family)
+ − 891 family (cdr family))
+ − 892 (if (assoc cur-family font-x-family-mappings)
+ − 893 ;; If the family name is an alias as defined by
+ − 894 ;; font-x-family-mappings, then append those families
+ − 895 ;; to the front of 'family' and continue in the loop.
+ − 896 ;; #### jhar: I don't know about ns font names, so using X mappings
+ − 897 (setq family (append
+ − 898 (cdr-safe (assoc cur-family
+ − 899 font-x-family-mappings))
+ − 900 family))
+ − 901 ;; CARL: Need help here - I am not familiar with the NS font
+ − 902 ;; model
+ − 903 (setq font-name "UNKNOWN FORMULA GOES HERE"
+ − 904 done (try-font-name font-name device))))
+ − 905 (if done font-name))))
+ − 906
+ − 907
+ − 908 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 909 ;;; The window-system dependent code (mswindows-style)
+ − 910 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 911
+ − 912 (defconst mswindows-font-weight-mappings
872
+ − 913 '((:thin . "Thin")
+ − 914 (:extra-light . "Extra Light")
428
+ − 915 (:light . "Light")
872
+ − 916 (:demi-light . "Light")
+ − 917 (:demi . "Light")
+ − 918 (:book . "Medium")
428
+ − 919 (:medium . "Medium")
+ − 920 (:normal . "Normal")
872
+ − 921 (:demi-bold . "Demi Bold")
428
+ − 922 (:bold . "Bold")
+ − 923 (:regular . "Regular")
872
+ − 924 (:extra-bold . "Extra Bold")
+ − 925 (:heavy . "Heavy"))
428
+ − 926 "An assoc list mapping keywords to actual mswindows specific strings
+ − 927 for use in the 'weight' field of an mswindows font string.")
+ − 928
+ − 929 (defvar font-mswindows-family-mappings
+ − 930 '(
+ − 931 ("serif" . ("times new roman"
+ − 932 "century schoolbook"
+ − 933 "book antiqua"
+ − 934 "bookman old style"))
+ − 935 ("sans-serif" . ("arial"
+ − 936 "verdana"
+ − 937 "lucida sans unicode"))
+ − 938 ("monospace" . ("courier new"
+ − 939 "lucida console"
+ − 940 "courier"
+ − 941 "terminal"))
+ − 942 ("cursive" . ("roman"
+ − 943 "script"))
+ − 944 )
+ − 945 "A list of font family mappings on mswindows devices.")
+ − 946
+ − 947 (defun mswindows-font-create-object (fontname &optional device)
707
+ − 948 "Return a font descriptor object for FONTNAME, appropriate for MS Windows devices."
428
+ − 949 (let ((case-fold-search t)
872
+ − 950 (font (declare-fboundp (mswindows-canonicalize-font-name fontname))))
428
+ − 951 (if (or (not (stringp font))
872
+ − 952 (not (string-match mswindows-font-regexp font)))
428
+ − 953 (make-font)
+ − 954 (let ((family (match-string 1 font))
872
+ − 955 (style (match-string 2 font))
+ − 956 (pointsize (match-string 3 font))
+ − 957 (effects (match-string 4 font))
+ − 958 (charset (match-string 5 font))
428
+ − 959 (retval nil)
+ − 960 (size nil)
+ − 961 (case-fold-search t)
+ − 962 )
872
+ − 963 (destructuring-bind (weight . slant)
+ − 964 (mswindows-parse-font-style style)
+ − 965 (if (equal pointsize "") (setq pointsize nil))
+ − 966 (if pointsize (setq size (concat pointsize "pt")))
+ − 967 (if weight (setq weight
+ − 968 (intern-soft
+ − 969 (concat ":" (downcase (replace-in-string
+ − 970 weight " " "-"))))))
+ − 971 (setq retval (make-font :family family
+ − 972 :weight weight
+ − 973 :size size
+ − 974 :encoding charset))
+ − 975 (set-font-bold-p retval (eq :bold weight))
+ − 976 (cond
+ − 977 ((null slant) nil)
+ − 978 ((string-match "[iI]talic" slant)
+ − 979 (set-font-italic-p retval t)))
+ − 980 (cond
+ − 981 ((null effects) nil)
+ − 982 ((string-match "^[uU]nderline [sS]trikeout" effects)
+ − 983 (set-font-underline-p retval t)
+ − 984 (set-font-strikethru-p retval t))
+ − 985 ((string-match "[uU]nderline" effects)
+ − 986 (set-font-underline-p retval t))
+ − 987 ((string-match "[sS]trikeout" effects)
+ − 988 (set-font-strikethru-p retval t)))
+ − 989 retval)))))
428
+ − 990
+ − 991 (defun mswindows-font-create-name (fontobj &optional device)
707
+ − 992 "Return a font name constructed from FONTOBJ, appropriate for MS Windows devices."
428
+ − 993 (if (and (not (or (font-family fontobj)
+ − 994 (font-weight fontobj)
+ − 995 (font-size fontobj)
+ − 996 (font-registry fontobj)
+ − 997 (font-encoding fontobj)))
+ − 998 (= (font-style fontobj) 0))
+ − 999 (face-font 'default)
+ − 1000 (or device (setq device (selected-device)))
+ − 1001 (let* ((default (font-default-object-for-device device))
+ − 1002 (family (or (font-family fontobj)
+ − 1003 (font-family default)))
+ − 1004 (weight (or (font-weight fontobj) :regular))
3094
+ − 1005 (size (or (font-size fontobj)
428
+ − 1006 (font-size default)))
+ − 1007 (underline-p (font-underline-p fontobj))
+ − 1008 (strikeout-p (font-strikethru-p fontobj))
872
+ − 1009 (encoding (font-encoding fontobj)))
428
+ − 1010 (if (stringp family)
+ − 1011 (setq family (list family)))
+ − 1012 (setq weight (font-higher-weight weight
+ − 1013 (and (font-bold-p fontobj) :bold)))
+ − 1014 (if (stringp size)
+ − 1015 (setq size (truncate (font-spatial-to-canonical size device))))
+ − 1016 (setq weight (or (cdr-safe
+ − 1017 (assq weight mswindows-font-weight-mappings)) ""))
+ − 1018 (let ((done nil) ; Did we find a good font yet?
+ − 1019 (font-name nil) ; font name we are currently checking
+ − 1020 (cur-family nil) ; current family we are checking
+ − 1021 )
+ − 1022 (while (and family (not done))
+ − 1023 (setq cur-family (car family)
+ − 1024 family (cdr family))
+ − 1025 (if (assoc cur-family font-mswindows-family-mappings)
+ − 1026 ;; If the family name is an alias as defined by
+ − 1027 ;; font-mswindows-family-mappings, then append those families
+ − 1028 ;; to the front of 'family' and continue in the loop.
+ − 1029 (setq family (append
+ − 1030 (cdr-safe (assoc cur-family
+ − 1031 font-mswindows-family-mappings))
+ − 1032 family))
+ − 1033 ;; We treat oblique and italic as equivalent. Don't ask.
+ − 1034 ;; Courier New:Bold Italic:10:underline strikeout:western
872
+ − 1035 (setq font-name (format "%s:%s:%s:%s:%s"
+ − 1036 cur-family
+ − 1037 (mswindows-construct-font-style
+ − 1038 weight
+ − 1039 (if (font-italic-p fontobj)
+ − 1040 "Italic" ""))
428
+ − 1041 (if size
+ − 1042 (int-to-string size) "10")
+ − 1043 (if underline-p
+ − 1044 (if strikeout-p
+ − 1045 "underline strikeout"
+ − 1046 "underline")
+ − 1047 (if strikeout-p "strikeout" ""))
+ − 1048 (if encoding
+ − 1049 encoding ""))
+ − 1050 done (try-font-name font-name device))))
+ − 1051 (if done font-name)))))
+ − 1052
+ − 1053
+ − 1054 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1055 ;;; Now overwrite the original copy of set-face-font with our own copy that
+ − 1056 ;;; can deal with either syntax.
+ − 1057 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1058 ;;; ###autoload
+ − 1059 (defun font-set-face-font (&optional face font &rest args)
+ − 1060 (cond
+ − 1061 ((and (vectorp font) (= (length font) 12))
+ − 1062 (let ((font-name (font-create-name font)))
+ − 1063 (set-face-property face 'font-specification font)
+ − 1064 (cond
+ − 1065 ((null font-name) ; No matching font!
+ − 1066 nil)
+ − 1067 ((listp font-name) ; For TTYs
+ − 1068 (let (cur)
+ − 1069 (while font-name
+ − 1070 (setq cur (car font-name)
+ − 1071 font-name (cdr font-name))
+ − 1072 (apply 'set-face-property face (car cur) (cdr cur) args))))
3094
+ − 1073 (t
428
+ − 1074 (apply 'set-face-font face font-name args)
+ − 1075 (apply 'set-face-underline-p face (font-underline-p font) args)
+ − 1076 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
+ − 1077 (fboundp 'set-face-display-table))
+ − 1078 (apply 'set-face-display-table
+ − 1079 face font-caps-display-table args))
+ − 1080 (apply 'set-face-property face 'strikethru (or
+ − 1081 (font-linethrough-p font)
+ − 1082 (font-strikethru-p font))
+ − 1083 args))
3094
+ − 1084 ;;; this used to be default with preceding conditioned on font-running-xemacs
+ − 1085 ; (t
+ − 1086 ; (condition-case nil
+ − 1087 ; (apply 'set-face-font face font-name args)
+ − 1088 ; (error
+ − 1089 ; (let ((args (car-safe args)))
+ − 1090 ; (and (or (font-bold-p font)
+ − 1091 ; (memq (font-weight font) '(:bold :demi-bold)))
+ − 1092 ; (make-face-bold face args t))
+ − 1093 ; (and (font-italic-p font) (make-face-italic face args t)))))
+ − 1094 ; (apply 'set-face-underline-p face (font-underline-p font) args))
+ − 1095 )))
428
+ − 1096 (t
+ − 1097 ;; Let the original set-face-font signal any errors
+ − 1098 (set-face-property face 'font-specification nil)
+ − 1099 (apply 'set-face-font face font args))))
+ − 1100
+ − 1101
+ − 1102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1103 ;;; Now for emacsen specific stuff
+ − 1104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1105 (defun font-update-device-fonts (device)
+ − 1106 ;; Update all faces that were created with the 'font' package
+ − 1107 ;; to appear correctly on the new device. This should be in the
+ − 1108 ;; create-device-hook. This is XEmacs 19.12+ specific
+ − 1109 (let ((faces (face-list 2))
+ − 1110 (cur nil)
+ − 1111 (font-spec nil))
+ − 1112 (while faces
+ − 1113 (setq cur (car faces)
+ − 1114 faces (cdr faces)
+ − 1115 font-spec (face-property cur 'font-specification))
+ − 1116 (if font-spec
+ − 1117 (set-face-font cur font-spec device)))))
+ − 1118
+ − 1119 (defun font-update-one-face (face &optional device-list)
+ − 1120 ;; Update FACE on all devices in DEVICE-LIST
+ − 1121 ;; DEVICE_LIST defaults to a list of all active devices
+ − 1122 (setq device-list (or device-list (device-list)))
+ − 1123 (if (devicep device-list)
+ − 1124 (setq device-list (list device-list)))
+ − 1125 (let* ((cur-device nil)
502
+ − 1126 (font-spec (face-property face 'font-specification)))
428
+ − 1127 (if (not font-spec)
+ − 1128 ;; Hey! Don't mess with fonts we didn't create in the
+ − 1129 ;; first place.
+ − 1130 nil
+ − 1131 (while device-list
+ − 1132 (setq cur-device (car device-list)
+ − 1133 device-list (cdr device-list))
+ − 1134 (if (not (device-live-p cur-device))
+ − 1135 ;; Whoah!
+ − 1136 nil
+ − 1137 (if font-spec
+ − 1138 (set-face-font face font-spec cur-device)))))))
+ − 1139
+ − 1140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1141 ;;; Various color related things
+ − 1142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1143 (cond
+ − 1144 ((fboundp 'display-warning)
+ − 1145 (fset 'font-warn 'display-warning))
+ − 1146 ((fboundp 'w3-warn)
+ − 1147 (fset 'font-warn 'w3-warn))
+ − 1148 ((fboundp 'url-warn)
+ − 1149 (fset 'font-warn 'url-warn))
+ − 1150 ((fboundp 'warn)
+ − 1151 (defun font-warn (class message &optional level)
+ − 1152 (warn "(%s/%s) %s" class (or level 'warning) message)))
+ − 1153 (t
+ − 1154 (defun font-warn (class message &optional level)
+ − 1155 (save-excursion
+ − 1156 (set-buffer (get-buffer-create "*W3-WARNINGS*"))
+ − 1157 (goto-char (point-max))
+ − 1158 (save-excursion
+ − 1159 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
+ − 1160 (display-buffer (current-buffer))))))
+ − 1161
+ − 1162 (defun font-lookup-rgb-components (color)
+ − 1163 "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
+ − 1164 The list (R G B) is returned, or an error is signaled if the lookup fails."
2527
+ − 1165 (let ((lib-list (if-boundp 'x-library-search-path
428
+ − 1166 x-library-search-path
+ − 1167 (list "/usr/X11R6/lib/X11/"
+ − 1168 "/usr/X11R5/lib/X11/"
+ − 1169 "/usr/lib/X11R6/X11/"
+ − 1170 "/usr/lib/X11R5/X11/"
+ − 1171 "/usr/local/X11R6/lib/X11/"
+ − 1172 "/usr/local/X11R5/lib/X11/"
+ − 1173 "/usr/local/lib/X11R6/X11/"
+ − 1174 "/usr/local/lib/X11R5/X11/"
+ − 1175 "/usr/X11/lib/X11/"
+ − 1176 "/usr/lib/X11/"
3125
+ − 1177 "/usr/share/X11/"
428
+ − 1178 "/usr/local/lib/X11/"
3125
+ − 1179 "/usr/local/share/X11/"
428
+ − 1180 "/usr/X386/lib/X11/"
+ − 1181 "/usr/x386/lib/X11/"
+ − 1182 "/usr/XFree86/lib/X11/"
+ − 1183 "/usr/unsupported/lib/X11/"
+ − 1184 "/usr/athena/lib/X11/"
+ − 1185 "/usr/local/x11r5/lib/X11/"
+ − 1186 "/usr/lpp/Xamples/lib/X11/"
+ − 1187 "/usr/openwin/lib/X11/"
+ − 1188 "/usr/openwin/share/lib/X11/")))
+ − 1189 (file font-rgb-file)
+ − 1190 r g b)
+ − 1191 (if (not file)
+ − 1192 (while lib-list
+ − 1193 (setq file (expand-file-name "rgb.txt" (car lib-list)))
+ − 1194 (if (file-readable-p file)
+ − 1195 (setq lib-list nil
+ − 1196 font-rgb-file file)
+ − 1197 (setq lib-list (cdr lib-list)
+ − 1198 file nil))))
+ − 1199 (if (null file)
+ − 1200 (list 0 0 0)
+ − 1201 (save-excursion
+ − 1202 (set-buffer (find-file-noselect file))
+ − 1203 (if (not (= (aref (buffer-name) 0) ? ))
+ − 1204 (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*")))
+ − 1205 (save-excursion
+ − 1206 (save-restriction
+ − 1207 (widen)
+ − 1208 (goto-char (point-min))
+ − 1209 (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t)
+ − 1210 (progn
+ − 1211 (beginning-of-line)
+ − 1212 (setq r (* (read (current-buffer)) 256)
+ − 1213 g (* (read (current-buffer)) 256)
+ − 1214 b (* (read (current-buffer)) 256)))
+ − 1215 (font-warn 'color (format "No such color: %s" color))
+ − 1216 (setq r 0
+ − 1217 g 0
+ − 1218 b 0))
+ − 1219 (list r g b) ))))))
+ − 1220
+ − 1221 (defun font-hex-string-to-number (string)
+ − 1222 "Convert STRING to an integer by parsing it as a hexadecimal number."
+ − 1223 (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
+ − 1224 (?1 . 1) (?b . 11) (?B . 11)
+ − 1225 (?2 . 2) (?c . 12) (?C . 12)
+ − 1226 (?3 . 3) (?d . 13) (?D . 13)
+ − 1227 (?4 . 4) (?e . 14) (?E . 14)
+ − 1228 (?5 . 5) (?f . 15) (?F . 15)
+ − 1229 (?6 . 6)
+ − 1230 (?7 . 7)
+ − 1231 (?8 . 8)
+ − 1232 (?9 . 9)))
+ − 1233 (n 0)
+ − 1234 (i 0)
+ − 1235 (lim (length string)))
+ − 1236 (while (< i lim)
+ − 1237 (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0))
+ − 1238 i (1+ i)))
+ − 1239 n ))
+ − 1240
+ − 1241 (defun font-parse-rgb-components (color)
+ − 1242 "Parse RGB color specification and return a list of integers (R G B).
+ − 1243 #FEFEFE and rgb:fe/fe/fe style specifications are parsed."
+ − 1244 (let ((case-fold-search t)
+ − 1245 r g b str)
+ − 1246 (cond ((string-match "^#[0-9a-f]+$" color)
+ − 1247 (cond
+ − 1248 ((= (length color) 4)
+ − 1249 (setq r (font-hex-string-to-number (substring color 1 2))
+ − 1250 g (font-hex-string-to-number (substring color 2 3))
+ − 1251 b (font-hex-string-to-number (substring color 3 4))
+ − 1252 r (* r 4096)
+ − 1253 g (* g 4096)
+ − 1254 b (* b 4096)))
+ − 1255 ((= (length color) 7)
+ − 1256 (setq r (font-hex-string-to-number (substring color 1 3))
+ − 1257 g (font-hex-string-to-number (substring color 3 5))
+ − 1258 b (font-hex-string-to-number (substring color 5 7))
+ − 1259 r (* r 256)
+ − 1260 g (* g 256)
+ − 1261 b (* b 256)))
+ − 1262 ((= (length color) 10)
+ − 1263 (setq r (font-hex-string-to-number (substring color 1 4))
+ − 1264 g (font-hex-string-to-number (substring color 4 7))
+ − 1265 b (font-hex-string-to-number (substring color 7 10))
+ − 1266 r (* r 16)
+ − 1267 g (* g 16)
+ − 1268 b (* b 16)))
+ − 1269 ((= (length color) 13)
+ − 1270 (setq r (font-hex-string-to-number (substring color 1 5))
+ − 1271 g (font-hex-string-to-number (substring color 5 9))
+ − 1272 b (font-hex-string-to-number (substring color 9 13))))
+ − 1273 (t
+ − 1274 (font-warn 'color (format "Invalid RGB color specification: %s"
+ − 1275 color))
+ − 1276 (setq r 0
+ − 1277 g 0
+ − 1278 b 0))))
+ − 1279 ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
+ − 1280 color)
+ − 1281 (if (or (> (- (match-end 1) (match-beginning 1)) 4)
+ − 1282 (> (- (match-end 2) (match-beginning 2)) 4)
+ − 1283 (> (- (match-end 3) (match-beginning 3)) 4))
+ − 1284 (error "Invalid RGB color specification: %s" color)
+ − 1285 (setq str (match-string 1 color)
+ − 1286 r (* (font-hex-string-to-number str)
+ − 1287 (expt 16 (- 4 (length str))))
+ − 1288 str (match-string 2 color)
+ − 1289 g (* (font-hex-string-to-number str)
+ − 1290 (expt 16 (- 4 (length str))))
+ − 1291 str (match-string 3 color)
+ − 1292 b (* (font-hex-string-to-number str)
+ − 1293 (expt 16 (- 4 (length str)))))))
+ − 1294 (t
+ − 1295 (font-warn 'html (format "Invalid RGB color specification: %s"
+ − 1296 color))
+ − 1297 (setq r 0
+ − 1298 g 0
+ − 1299 b 0)))
+ − 1300 (list r g b) ))
+ − 1301
502
+ − 1302 (defun font-rgb-color-p (obj)
428
+ − 1303 (or (and (vectorp obj)
+ − 1304 (= (length obj) 4)
+ − 1305 (eq (aref obj 0) 'rgb))))
+ − 1306
502
+ − 1307 (defun font-rgb-color-red (obj) (aref obj 1))
+ − 1308 (defun font-rgb-color-green (obj) (aref obj 2))
+ − 1309 (defun font-rgb-color-blue (obj) (aref obj 3))
428
+ − 1310
+ − 1311 (defun font-color-rgb-components (color)
+ − 1312 "Return the RGB components of COLOR as a list of integers (R G B).
+ − 1313 16-bit values are always returned.
+ − 1314 #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
+ − 1315 into their components.
+ − 1316 RGB values for color names are looked up in the rgb.txt file.
+ − 1317 The variable x-library-search-path is use to locate the rgb.txt file."
+ − 1318 (let ((case-fold-search t))
+ − 1319 (cond
+ − 1320 ((and (font-rgb-color-p color) (floatp (aref color 1)))
+ − 1321 (list (* 65535 (aref color 0))
+ − 1322 (* 65535 (aref color 1))
+ − 1323 (* 65535 (aref color 2))))
+ − 1324 ((font-rgb-color-p color)
+ − 1325 (list (font-rgb-color-red color)
+ − 1326 (font-rgb-color-green color)
+ − 1327 (font-rgb-color-blue color)))
+ − 1328 ((and (vectorp color) (= 3 (length color)))
+ − 1329 (list (aref color 0) (aref color 1) (aref color 2)))
+ − 1330 ((and (listp color) (= 3 (length color)) (floatp (car color)))
+ − 1331 (mapcar #'(lambda (x) (* x 65535)) color))
+ − 1332 ((and (listp color) (= 3 (length color)))
+ − 1333 color)
+ − 1334 ((or (string-match "^#" color)
+ − 1335 (string-match "^rgb:" color))
+ − 1336 (font-parse-rgb-components color))
+ − 1337 ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)"
+ − 1338 color)
+ − 1339 (let ((r (string-to-number (match-string 1 color)))
+ − 1340 (g (string-to-number (match-string 2 color)))
+ − 1341 (b (string-to-number (match-string 3 color))))
+ − 1342 (if (floatp r)
+ − 1343 (setq r (round (* 255 r))
+ − 1344 g (round (* 255 g))
+ − 1345 b (round (* 255 b))))
+ − 1346 (font-parse-rgb-components (format "#%02x%02x%02x" r g b))))
+ − 1347 (t
+ − 1348 (font-lookup-rgb-components color)))))
+ − 1349
502
+ − 1350 (defun font-tty-compute-color-delta (col1 col2)
428
+ − 1351 (+
+ − 1352 (* (- (aref col1 0) (aref col2 0))
+ − 1353 (- (aref col1 0) (aref col2 0)))
+ − 1354 (* (- (aref col1 1) (aref col2 1))
+ − 1355 (- (aref col1 1) (aref col2 1)))
+ − 1356 (* (- (aref col1 2) (aref col2 2))
+ − 1357 (- (aref col1 2) (aref col2 2)))))
+ − 1358
+ − 1359 (defun font-tty-find-closest-color (r g b)
+ − 1360 ;; This is basically just a lisp copy of allocate_nearest_color
+ − 1361 ;; from objects-x.c from Emacs 19
+ − 1362 ;; We really should just check tty-color-list, but unfortunately
+ − 1363 ;; that does not include any RGB information at all.
+ − 1364 ;; So for now we just hardwire in the default list and call it
+ − 1365 ;; good for now.
+ − 1366 (setq r (/ r 65535.0)
+ − 1367 g (/ g 65535.0)
+ − 1368 b (/ b 65535.0))
+ − 1369 (let* ((color_def (vector r g b))
+ − 1370 (colors [([1.0 1.0 1.0] . "white")
+ − 1371 ([0.0 1.0 1.0] . "cyan")
+ − 1372 ([1.0 0.0 1.0] . "magenta")
+ − 1373 ([0.0 0.0 1.0] . "blue")
+ − 1374 ([1.0 1.0 0.0] . "yellow")
+ − 1375 ([0.0 1.0 0.0] . "green")
+ − 1376 ([1.0 0.0 0.0] . "red")
+ − 1377 ([0.0 0.0 0.0] . "black")])
+ − 1378 (no_cells (length colors))
+ − 1379 (x 1)
+ − 1380 (nearest 0)
+ − 1381 (nearest_delta 0)
+ − 1382 (trial_delta 0))
+ − 1383 (setq nearest_delta (font-tty-compute-color-delta (car (aref colors 0))
+ − 1384 color_def))
+ − 1385 (while (/= no_cells x)
+ − 1386 (setq trial_delta (font-tty-compute-color-delta (car (aref colors x))
+ − 1387 color_def))
+ − 1388 (if (< trial_delta nearest_delta)
+ − 1389 (setq nearest x
+ − 1390 nearest_delta trial_delta))
+ − 1391 (setq x (1+ x)))
+ − 1392 (cdr-safe (aref colors nearest))))
+ − 1393
+ − 1394 (defun font-normalize-color (color &optional device)
+ − 1395 "Return an RGB tuple, given any form of input. If an error occurs, black
+ − 1396 is returned."
+ − 1397 (case (device-type device)
+ − 1398 ((x pm)
+ − 1399 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
+ − 1400 (mswindows
+ − 1401 (let* ((rgb (font-color-rgb-components color))
+ − 1402 (color (apply 'format "#%02x%02x%02x" rgb)))
+ − 1403 (mswindows-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
+ − 1404 color))
+ − 1405 (tty
+ − 1406 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
+ − 1407 (ns
502
+ − 1408 (let ((vals (mapcar #'(lambda (x) (lsh x -8))
428
+ − 1409 (font-color-rgb-components color))))
+ − 1410 (apply 'format "RGB%02x%02x%02xff" vals)))
+ − 1411 (otherwise
+ − 1412 color)))
+ − 1413
+ − 1414 (defun font-set-face-background (&optional face color &rest args)
+ − 1415 (interactive)
+ − 1416 (condition-case nil
+ − 1417 (cond
+ − 1418 ((or (font-rgb-color-p color)
+ − 1419 (string-match "^#[0-9a-fA-F]+$" color))
+ − 1420 (apply 'set-face-background face
+ − 1421 (font-normalize-color color) args))
+ − 1422 (t
+ − 1423 (apply 'set-face-background face color args)))
+ − 1424 (error nil)))
+ − 1425
+ − 1426 (defun font-set-face-foreground (&optional face color &rest args)
+ − 1427 (interactive)
+ − 1428 (condition-case nil
+ − 1429 (cond
+ − 1430 ((or (font-rgb-color-p color)
+ − 1431 (string-match "^#[0-9a-fA-F]+$" color))
+ − 1432 (apply 'set-face-foreground face (font-normalize-color color) args))
+ − 1433 (t
+ − 1434 (apply 'set-face-foreground face color args)))
+ − 1435 (error nil)))
+ − 1436
+ − 1437 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1438 ;;; Support for 'blinking' fonts
+ − 1439 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1440 (defun font-map-windows (func &optional arg frame)
+ − 1441 (let* ((start (selected-window))
+ − 1442 (cur start)
+ − 1443 (result nil))
+ − 1444 (push (funcall func start arg) result)
+ − 1445 (while (not (eq start (setq cur (next-window cur))))
+ − 1446 (push (funcall func cur arg) result))
+ − 1447 result))
+ − 1448
+ − 1449 (defun font-face-visible-in-window-p (window face)
+ − 1450 (let ((st (window-start window))
+ − 1451 (nd (window-end window))
+ − 1452 (found nil)
+ − 1453 (face-at nil))
+ − 1454 (setq face-at (get-text-property st 'face (window-buffer window)))
+ − 1455 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
+ − 1456 (setq found t))
+ − 1457 (while (and (not found)
+ − 1458 (/= nd
+ − 1459 (setq st (next-single-property-change
+ − 1460 st 'face
+ − 1461 (window-buffer window) nd))))
+ − 1462 (setq face-at (get-text-property st 'face (window-buffer window)))
+ − 1463 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
+ − 1464 (setq found t)))
+ − 1465 found))
+ − 1466
+ − 1467 (defun font-blink-callback ()
+ − 1468 ;; Optimized to never invert the face unless one of the visible windows
+ − 1469 ;; is showing it.
3094
+ − 1470 (let ((faces (face-list t))
428
+ − 1471 (obj nil))
+ − 1472 (while faces
+ − 1473 (if (and (setq obj (face-property (car faces) 'font-specification))
+ − 1474 (font-blink-p obj)
+ − 1475 (memq t
3094
+ − 1476 (font-map-windows 'font-face-visible-in-window-p
+ − 1477 (car faces))))
428
+ − 1478 (invert-face (car faces)))
+ − 1479 (pop faces))))
+ − 1480
+ − 1481 (defcustom font-blink-interval 0.5
+ − 1482 "How often to blink faces"
+ − 1483 :type 'number
+ − 1484 :group 'faces)
+ − 1485
+ − 1486 (defun font-blink-initialize ()
+ − 1487 (cond
+ − 1488 ((featurep 'itimer)
+ − 1489 (if (get-itimer "font-blinker")
+ − 1490 (delete-itimer (get-itimer "font-blinker")))
+ − 1491 (start-itimer "font-blinker" 'font-blink-callback
+ − 1492 font-blink-interval
+ − 1493 font-blink-interval))
+ − 1494 ((fboundp 'run-at-time)
+ − 1495 (cancel-function-timers 'font-blink-callback)
776
+ − 1496 (declare-fboundp (run-at-time font-blink-interval
+ − 1497 font-blink-interval
+ − 1498 'font-blink-callback)))
428
+ − 1499 (t nil)))
+ − 1500
+ − 1501 (provide 'font)