Mercurial > hg > xemacs-beta

comparison lisp/font.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 3742ea8250b5 32b358a240b0
children 97eb4942aec8
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 2
3 ;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu) 3 ;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
4 ;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 4 ;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
5 ;; Copyright (C) 2002, 2004, 2005 Ben Wing. 5 ;; Copyright (C) 2002, 2004 Ben Wing.
6 6
7 ;; Author: wmperry 7 ;; Author: wmperry
8 ;; Maintainer: XEmacs Development Team 8 ;; Maintainer: XEmacs Development Team
9 ;; Created: 1997/09/05 15:44:37 9 ;; Created: 1997/09/05 15:44:37
10 ;; Keywords: faces 10 ;; Keywords: faces
26 ;; 02111-1307, USA. 26 ;; 02111-1307, USA.
27 27
28 ;;; Synched up with: Not in FSF 28 ;;; Synched up with: Not in FSF
29 29
30 ;;; Commentary: 30 ;;; Commentary:
31
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.
31 43
32 ;;; Code: 44 ;;; Code:
33 45
34 (globally-declare-fboundp 46 (globally-declare-fboundp
35 '(internal-facep fontsetp get-font-info 47 '(internal-facep fontsetp get-font-info
36 get-fontset-info mswindows-define-rgb-color cancel-function-timers 48 get-fontset-info mswindows-define-rgb-color cancel-function-timers
37 mswindows-font-regexp mswindows-canonicalize-font-name 49 mswindows-font-regexp mswindows-canonicalize-font-name
38 mswindows-parse-font-style mswindows-construct-font-style 50 mswindows-parse-font-style mswindows-construct-font-style
39 ;; #### perhaps we should rewrite font-warn to avoid the warning 51 ;; #### perhaps we should rewrite font-warn to avoid the warning
40 font-warn)) 52 ;; Eh, now I look at the code, we definitely should.
53 font-warn
54 fc-pattern-get-family fc-pattern-get-size fc-pattern-get-weight
55 fc-font-weight-translate-from-constant make-fc-pattern
56 fc-pattern-add-family fc-pattern-add-size))
41 57
42 (globally-declare-boundp 58 (globally-declare-boundp
43 '(global-face-data 59 '(global-face-data
44 x-font-regexp x-font-regexp-foundry-and-family 60 x-font-regexp x-font-regexp-foundry-and-family
61 fc-font-regexp
45 mswindows-font-regexp)) 62 mswindows-font-regexp))
46 63
47 (require 'cl) 64 (require 'cl)
48 65
49 (eval-and-compile 66 (eval-and-compile
87 104
88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
89 ;;; Lots of variables / keywords for use later in the program 106 ;;; Lots of variables / keywords for use later in the program
90 ;;; Not much should need to be modified 107 ;;; Not much should need to be modified
91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
92 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version)) 109 ;; #### These aren't window system mappings
93 "Whether we are running in XEmacs or not.")
94
95 (defmacro define-font-keywords (&rest keys)
96 `(eval-and-compile
97 (let ((keywords (quote ,keys)))
98 (while keywords
99 (or (boundp (car keywords))
100 (set (car keywords) (car keywords)))
101 (setq keywords (cdr keywords))))))
102
103 (defconst font-window-system-mappings 110 (defconst font-window-system-mappings
104 '((x . (x-font-create-name x-font-create-object)) 111 '((x . (x-font-create-name x-font-create-object))
105 (gtk . (x-font-create-name x-font-create-object)) 112 (gtk . (x-font-create-name x-font-create-object))
106 (ns . (ns-font-create-name ns-font-create-object)) 113 ;; #### FIXME should this handle fontconfig font objects?
114 (fc . (fc-font-create-name fc-font-create-object))
107 (mswindows . (mswindows-font-create-name mswindows-font-create-object)) 115 (mswindows . (mswindows-font-create-name mswindows-font-create-object))
108 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME 116 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
117 ;; #### what is this bogosity?
109 (tty . (tty-font-create-plist tty-font-create-object))) 118 (tty . (tty-font-create-plist tty-font-create-object)))
110 "An assoc list mapping device types to a list of translations. 119 "An assoc list mapping device types to a list of translations.
111 120
112 The first function creates a font name from a font descriptor object. 121 The first function creates a font name from a font descriptor object.
113 The second performs the reverse translation.") 122 The second performs the reverse translation.")
114
115 (defconst ns-font-weight-mappings
116 '((:extra-light . "extralight")
117 (:light . "light")
118 (:demi-light . "demilight")
119 (:medium . "medium")
120 (:normal . "medium")
121 (:demi-bold . "demibold")
122 (:bold . "bold")
123 (:extra-bold . "extrabold"))
124 "An assoc list mapping keywords to actual NeXTstep specific
125 information to use")
126 123
127 (defconst x-font-weight-mappings 124 (defconst x-font-weight-mappings
128 '((:extra-light . "extralight") 125 '((:extra-light . "extralight")
129 (:light . "light") 126 (:light . "light")
130 (:demi-light . "demilight") 127 (:demi-light . "demilight")
146 143
147 (defvar font-maximum-slippage "1pt" 144 (defvar font-maximum-slippage "1pt"
148 "How much a font is allowed to vary from the desired size.") 145 "How much a font is allowed to vary from the desired size.")
149 146
150 ;; Canonical (internal) sizes are in points. 147 ;; Canonical (internal) sizes are in points.
151 ;; Registry 148
152 (define-font-keywords :family :style :size :registry :encoding) 149 ;; Property keywords: :family :style :size :registry :encoding :weight
153 150 ;; Weight keywords: :extra-light :light :demi-light :medium
154 (define-font-keywords 151 ;; :normal :demi-bold :bold :extra-bold
155 :weight :extra-light :light :demi-light :medium :normal :demi-bold 152 ;; See GNU Emacs 21.4 for more properties and keywords we should support
156 :bold :extra-bold)
157 153
158 (defvar font-style-keywords nil) 154 (defvar font-style-keywords nil)
159 155
160 (defun set-font-family (fontobj family) 156 (defun set-font-family (fontobj family)
161 (aset fontobj 1 family)) 157 (aset fontobj 1 family))
205 (defconst ,(intern (format "font-%s-mask" attr)) (lsh 1 ,mask) 201 (defconst ,(intern (format "font-%s-mask" attr)) (lsh 1 ,mask)
206 ,(format 202 ,(format
207 "Bitmask for whether a font is to be rendered in %s or not." 203 "Bitmask for whether a font is to be rendered in %s or not."
208 attr)) 204 attr))
209 (defun ,(intern (format "font-%s-p" attr)) (fontobj) 205 (defun ,(intern (format "font-%s-p" attr)) (fontobj)
210 ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr) 206 ,(format "Whether FONTOBJ will be rendered in `%s' or not." attr)
211 (if (/= 0 (logand (font-style fontobj) 207 (if (/= 0 (logand (font-style fontobj)
212 ,(intern (format "font-%s-mask" attr)))) 208 ,(intern (format "font-%s-mask" attr))))
213 t 209 t
214 nil)) 210 nil))
215 (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val) 211 (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val)
216 ,(format "Set whether FONTOBJ will be renderd in `%s' or not." 212 ,(format "Set whether FONTOBJ will be rendered in `%s' or not."
217 attr) 213 attr)
218 (cond 214 (cond
219 (val 215 (val
220 (set-font-style fontobj (logior (font-style fontobj) 216 (set-font-style fontobj (logior (font-style fontobj)
221 ,(intern 217 ,(intern
246 ;; Standard ASCII characters 242 ;; Standard ASCII characters
247 (while (< i 26) 243 (while (< i 26)
248 (put-display-table (+ i ?a) (+ i ?A) table) 244 (put-display-table (+ i ?a) (+ i ?A) table)
249 (setq i (1+ i))) 245 (setq i (1+ i)))
250 ;; Now ISO translations 246 ;; Now ISO translations
247 ;; #### FIXME what's this for??
251 (setq i 224) 248 (setq i 224)
252 (while (< i 247) ;; Agrave - Ouml 249 (while (< i 247) ;; Agrave - Ouml
253 (put-display-table i (- i 32) table) 250 (put-display-table i (- i 32) table)
254 (setq i (1+ i))) 251 (setq i (1+ i)))
255 (setq i 248) 252 (setq i 248)
259 table)) 256 table))
260 257
261 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 258 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
262 ;;; Utility functions 259 ;;; Utility functions
263 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
264 (defun set-font-style-by-keywords (fontobj styles) 261 ;; #### unused?
265 (make-local-variable 'font-func) 262 ; (defun set-font-style-by-keywords (fontobj styles)
266 (declare (special font-func)) 263 ; (make-local-variable 'font-func)
267 (if (listp styles) 264 ; (declare (special font-func))
268 (while styles 265 ; (if (listp styles)
269 (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords))) 266 ; (while styles
270 styles (cdr styles)) 267 ; (setq font-func (car-safe (cdr-safe (assq (car styles)
271 (and (fboundp font-func) (funcall font-func fontobj t))) 268 ; font-style-keywords)))
272 (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords)))) 269 ; styles (cdr styles))
273 (and (fboundp font-func) (funcall font-func fontobj t)))) 270 ; (and (fboundp font-func) (funcall font-func fontobj t)))
274 271 ; (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
275 (defun font-properties-from-style (fontobj) 272 ; (and (fboundp font-func) (funcall font-func fontobj t))))
276 (let ((todo font-style-keywords) 273
277 type func retval) 274 ;; #### unused?
278 (while todo 275 ; (defun font-properties-from-style (fontobj)
279 (setq func (cdr (cdr (car todo))) 276 ; (let ((todo font-style-keywords)
280 type (car (pop todo))) 277 ; type func retval)
281 (if (funcall func fontobj) 278 ; (while todo
282 (setq retval (cons type retval)))) 279 ; (setq func (cdr (cdr (car todo)))
283 retval)) 280 ; type (car (pop todo)))
284 281 ; (if (funcall func fontobj)
285 (defun font-unique (list) 282 ; (setq retval (cons type retval))))
286 (let ((retval) 283 ; retval))
287 (cur))
288 (while list
289 (setq cur (car list)
290 list (cdr list))
291 (if (member cur retval)
292 nil
293 (setq retval (cons cur retval))))
294 (nreverse retval)))
295 284
296 (defun font-higher-weight (w1 w2) 285 (defun font-higher-weight (w1 w2)
297 (let ((index1 (length (memq w1 font-possible-weights))) 286 (let ((index1 (length (memq w1 font-possible-weights)))
298 (index2 (length (memq w2 font-possible-weights)))) 287 (index2 (length (memq w2 font-possible-weights))))
299 (cond 288 (cond
327 ;; to 1024x768 resolution on a 17" screen 316 ;; to 1024x768 resolution on a 17" screen
328 (pix-width (float (or (device-pixel-width device) 1024))) 317 (pix-width (float (or (device-pixel-width device) 1024)))
329 (mm-width (float (or (device-mm-width device) 293))) 318 (mm-width (float (or (device-mm-width device) 293)))
330 (retval nil)) 319 (retval nil))
331 (cond 320 (cond
332 ;; the following string-match is broken, there will never be a 321 ;; #### this is pretty bogus and should probably be made gone
333 ;; left operand detected 322 ;; or supported at a higher level
334 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee! 323 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee!
335 (let ((math-func (intern (match-string 1 spec))) 324 (let ((math-func (intern (match-string 1 spec)))
336 (other (font-spatial-to-canonical 325 (other (font-spatial-to-canonical
337 (substring spec (match-end 0) nil))) 326 (substring spec (match-end 0) nil)))
338 (default (font-spatial-to-canonical 327 (default (font-spatial-to-canonical
359 ((member type '("inch" "in")) 348 ((member type '("inch" "in"))
360 (setq retval (* num 72.0))) 349 (setq retval (* num 72.0)))
361 ((string= type "mm") 350 ((string= type "mm")
362 (setq retval (* num (/ 72.0 25.4)))) 351 (setq retval (* num (/ 72.0 25.4))))
363 ((string= type "cm") 352 ((string= type "cm")
364 (setq retval (* num 10 (/ 72.0 25.4)))) 353 (setq retval (* num (/ 72.0 2.54))))
365 (t 354 (t
366 (setq retval num)) 355 (setq retval num))
367 ) 356 )
368 retval)))) 357 retval))))
369 358
408 (font-spatial-to-canonical (font-size fontobj-1)))) 397 (font-spatial-to-canonical (font-size fontobj-1))))
409 (size-2 (and (font-size fontobj-2) 398 (size-2 (and (font-size fontobj-2)
410 (font-spatial-to-canonical (font-size fontobj-2))))) 399 (font-spatial-to-canonical (font-size fontobj-2)))))
411 (set-font-weight retval (font-higher-weight (font-weight fontobj-1) 400 (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
412 (font-weight fontobj-2))) 401 (font-weight fontobj-2)))
413 (set-font-family retval (font-unique (append (font-family fontobj-1) 402 (set-font-family retval
414 (font-family fontobj-2)))) 403 (delete-duplicates (append (font-family fontobj-1)
404 (font-family fontobj-2))
405 :test #'equal))
415 (set-font-style retval (logior (font-style fontobj-1) 406 (set-font-style retval (logior (font-style fontobj-1)
416 (font-style fontobj-2))) 407 (font-style fontobj-2)))
417 (set-font-registry retval (or (font-registry fontobj-1) 408 (set-font-registry retval (or (font-registry fontobj-1)
418 (font-registry fontobj-2))) 409 (font-registry fontobj-2)))
419 (set-font-encoding retval (or (font-encoding fontobj-1) 410 (set-font-encoding retval (or (font-encoding fontobj-1)
443 (while args 434 (while args
444 (setq retval (font-combine-fonts-internal retval (car args)) 435 (setq retval (font-combine-fonts-internal retval (car args))
445 args (cdr args))) 436 args (cdr args)))
446 retval)))) 437 retval))))
447 438
439 (defvar font-default-cache nil)
440
441 ;;;###autoload
442 (defun font-default-font-for-device (&optional device)
443 (or device (setq device (selected-device)))
444 (font-truename
445 (make-font-specifier
446 (face-font-name 'default device))))
447
448 ;;;###autoload
449 (defun font-default-object-for-device (&optional device)
450 (let ((font (font-default-font-for-device device)))
451 (or (cdr-safe (assoc font font-default-cache))
452 (let ((object (font-create-object font)))
453 (push (cons font object) font-default-cache)
454 object))))
455
456 ;;;###autoload
457 (defun font-default-family-for-device (&optional device)
458 (font-family (font-default-object-for-device (or device (selected-device)))))
459
460 ;;;###autoload
461 (defun font-default-registry-for-device (&optional device)
462 (font-registry (font-default-object-for-device (or device (selected-device)))))
463
464 ;;;###autoload
465 (defun font-default-encoding-for-device (&optional device)
466 (font-encoding (font-default-object-for-device (or device (selected-device)))))
467
468 ;;;###autoload
469 (defun font-default-size-for-device (&optional device)
470 ;; face-height isn't the right thing (always 1 pixel too high?)
471 ;; (if font-running-xemacs
472 ;; (format "%dpx" (face-height 'default device))
473 (font-size (font-default-object-for-device (or device (selected-device)))))
474
448 475
449 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
450 ;;; The window-system dependent code (TTY-style) 477 ;;; The window-system dependent code (TTY-style)
451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 478 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
452 (defun tty-font-create-object (fontname &optional device) 479 (defun tty-font-create-object (fontname &optional device)
466 493
467 494
468 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 495 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
469 ;;; The window-system dependent code (X-style) 496 ;;; The window-system dependent code (X-style)
470 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 497 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
471 (defvar font-x-font-regexp (or (and font-running-xemacs 498 (defvar font-x-font-regexp (when (and (boundp 'x-font-regexp)
472 (boundp 'x-font-regexp) 499 x-font-regexp)
473 x-font-regexp)
474 (let 500 (let
475 ((- "[-?]") 501 ((- "[-?]")
476 (foundry "[^-]*") 502 (foundry "[^-]*")
477 (family "[^-]*") 503 (family "[^-]*")
478 ;(weight "\\(bold\\|demibold\\|medium\\|black\\)") 504 ;(weight "\\(bold\\|demibold\\|medium\\|black\\)")
495 pixelsize - pointsize - resx - resy - spacing - avgwidth - 521 pixelsize - pointsize - resx - resy - spacing - avgwidth -
496 registry - encoding "\\'" 522 registry - encoding "\\'"
497 )))) 523 ))))
498 524
499 (defvar font-x-registry-and-encoding-regexp 525 (defvar font-x-registry-and-encoding-regexp
500 (or (and font-running-xemacs 526 (when (and (boundp 'x-font-regexp-registry-and-encoding)
501 (boundp 'x-font-regexp-registry-and-encoding) 527 (symbol-value 'x-font-regexp-registry-and-encoding))
502 (symbol-value 'x-font-regexp-registry-and-encoding)) 528 (let ((- "[-?]")
503 (let ((- "[-?]") 529 (registry "[^-]*")
504 (registry "[^-]*") 530 (encoding "[^-]+"))
505 (encoding "[^-]+")) 531 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
506 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
507 532
508 (defvar font-x-family-mappings 533 (defvar font-x-family-mappings
509 '( 534 '(
510 ("serif" . ("new century schoolbook" 535 ("serif" . ("new century schoolbook"
511 "utopia" 536 "utopia"
541 (defun x-font-create-object (fontname &optional device) 566 (defun x-font-create-object (fontname &optional device)
542 "Return a font descriptor object for FONTNAME, appropriate for X devices." 567 "Return a font descriptor object for FONTNAME, appropriate for X devices."
543 (let ((case-fold-search t)) 568 (let ((case-fold-search t))
544 (if (or (not (stringp fontname)) 569 (if (or (not (stringp fontname))
545 (not (string-match font-x-font-regexp fontname))) 570 (not (string-match font-x-font-regexp fontname)))
546 (make-font) 571 (if (and (stringp fontname)
572 (featurep 'xft-fonts)
573 (string-match font-xft-font-regexp fontname))
574 ;; Return an XFT font.
575 (xft-font-create-object fontname)
576 ;; It's unclear how to parse the font; return an unspecified
577 ;; one.
578 (make-font))
547 (let ((family nil) 579 (let ((family nil)
548 (size nil) 580 (size nil)
549 (weight (match-string 1 fontname)) 581 (weight (match-string 1 fontname))
550 (slant (match-string 2 fontname)) 582 (slant (match-string 2 fontname))
551 (swidth (match-string 3 fontname)) 583 (swidth (match-string 3 fontname))
595 (x-font-families-for-device device t)) 627 (x-font-families-for-device device t))
596 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0))) 628 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
597 (aref menu 0))) 629 (aref menu 0)))
598 (normal (mapcar #'(lambda (x) (if x (aref x 0))) 630 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
599 (aref menu 1)))) 631 (aref menu 1))))
600 (sort (font-unique (nconc scaled normal)) 'string-lessp)))) 632 (sort (delete-duplicates (nconc scaled normal) :test 'equal)
633 'string-lessp))))
601 (cons "monospace" (mapcar 'car font-x-family-mappings)))) 634 (cons "monospace" (mapcar 'car font-x-family-mappings))))
602
603 (defvar font-default-cache nil)
604
605 ;;;###autoload
606 (defun font-default-font-for-device (&optional device)
607 (or device (setq device (selected-device)))
608 (if font-running-xemacs
609 (font-truename
610 (make-font-specifier
611 (face-font-name 'default device)))
612 (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
613 (if (and (fboundp 'fontsetp) (fontsetp font))
614 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
615 font))))
616
617 ;;;###autoload
618 (defun font-default-object-for-device (&optional device)
619 (let ((font (font-default-font-for-device device)))
620 (or (cdr-safe (assoc font font-default-cache))
621 (let ((object (font-create-object font)))
622 (push (cons font object) font-default-cache)
623 object))))
624
625 ;;;###autoload
626 (defun font-default-family-for-device (&optional device)
627 (font-family (font-default-object-for-device (or device (selected-device)))))
628
629 ;;;###autoload
630 (defun font-default-registry-for-device (&optional device)
631 (font-registry (font-default-object-for-device (or device (selected-device)))))
632
633 ;;;###autoload
634 (defun font-default-encoding-for-device (&optional device)
635 (font-encoding (font-default-object-for-device (or device (selected-device)))))
636
637 ;;;###autoload
638 (defun font-default-size-for-device (&optional device)
639 ;; face-height isn't the right thing (always 1 pixel too high?)
640 ;; (if font-running-xemacs
641 ;; (format "%dpx" (face-height 'default device))
642 (font-size (font-default-object-for-device (or device (selected-device)))))
643 635
644 (defun x-font-create-name (fontobj &optional device) 636 (defun x-font-create-name (fontobj &optional device)
645 "Return a font name constructed from FONTOBJ, appropriate for X devices." 637 "Return a font name constructed from FONTOBJ, appropriate for X devices."
646 (if (and (not (or (font-family fontobj) 638 (if (and (not (or (font-family fontobj)
647 (font-weight fontobj) 639 (font-weight fontobj)
654 (let* ((default (font-default-object-for-device device)) 646 (let* ((default (font-default-object-for-device device))
655 (family (or (font-family fontobj) 647 (family (or (font-family fontobj)
656 (font-family default) 648 (font-family default)
657 (x-font-families-for-device device))) 649 (x-font-families-for-device device)))
658 (weight (or (font-weight fontobj) :medium)) 650 (weight (or (font-weight fontobj) :medium))
659 (size (or (if font-running-xemacs 651 (size (or (font-size fontobj)
660 (font-size fontobj))
661 (font-size default))) 652 (font-size default)))
662 (registry (or (font-registry fontobj) 653 (registry (or (font-registry fontobj)
663 (font-registry default) 654 (font-registry default)
664 "*")) 655 "*"))
665 (encoding (or (font-encoding fontobj) 656 (encoding (or (font-encoding fontobj)
712 slants (cdr slants) 703 slants (cdr slants)
713 done (try-font-name font-name device)))))) 704 done (try-font-name font-name device))))))
714 (if done font-name))))) 705 (if done font-name)))))
715 706
716 707
717 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 708 ;;; Cache building code
718 ;;; The window-system dependent code (NS-style) 709 ;;;###autoload
719 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 710 (defun x-font-build-cache (&optional device)
720 (defun ns-font-families-for-device (&optional device no-resetp) 711 (let ((hash-table (make-hash-table :test 'equal :size 15))
721 ;; For right now, assume we are going to have the same storage for 712 (fonts (mapcar 'x-font-create-object
722 ;; device fonts for NS as we do for X. Is this a valid assumption? 713 (font-list "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
714 (plist nil)
715 (cur nil))
716 (while fonts
717 (setq cur (car fonts)
718 fonts (cdr fonts)
719 plist (cl-gethash (car (font-family cur)) hash-table))
720 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
721 (setq plist (plist-put plist 'weights (cons (font-weight cur)
722 (plist-get plist 'weights)))))
723 (if (not (member (font-size cur) (plist-get plist 'sizes)))
724 (setq plist (plist-put plist 'sizes (cons (font-size cur)
725 (plist-get plist 'sizes)))))
726 (if (and (font-oblique-p cur)
727 (not (memq 'oblique (plist-get plist 'styles))))
728 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
729 (if (and (font-italic-p cur)
730 (not (memq 'italic (plist-get plist 'styles))))
731 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
732 (cl-puthash (car (font-family cur)) plist hash-table))
733 hash-table))
734
735
736 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
737 ;;; The rendering engine-dependent code (Xft-style)
738 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
739
740 ;;; #### FIXME actually, this section should be fc-*, right?
741
742 (defvar font-xft-font-regexp
743 (concat "\\`"
744 #r"\(\\-\|\\:\|\\,\|[^:-]\)*" ; optional foundry and family
745 ; (allows for escaped colons,
746 ; dashes, commas)
747 "\\(-[0-9]*\\(\\.[0-9]*\\)?\\)?" ; optional size (points)
748 "\\(:[^:]*\\)*" ; optional properties
749 ; not necessarily key=value!!
750 "\\'"
751 ))
752
753 (defvar font-xft-family-mappings
754 ;; #### FIXME this shouldn't be needed or used for Xft
755 '(("serif" . ("new century schoolbook"
756 "utopia"
757 "charter"
758 "times"
759 "lucidabright"
760 "garamond"
761 "palatino"
762 "times new roman"
763 "baskerville"
764 "bookman"
765 "bodoni"
766 "computer modern"
767 "rockwell"
768 ))
769 ("sans-serif" . ("lucida"
770 "helvetica"
771 "gills-sans"
772 "avant-garde"
773 "univers"
774 "optima"))
775 ("elfin" . ("tymes"))
776 ("monospace" . ("courier"
777 "fixed"
778 "lucidatypewriter"
779 "clean"
780 "terminal"))
781 ("cursive" . ("sirene"
782 "zapf chancery"))
783 )
784 "A list of font family mappings on Xft devices.")
785
786 (defun xft-font-create-object (fontname &optional device)
787 "Return a font descriptor object for FONTNAME, appropriate for Xft.
788
789 Optional DEVICE defaults to `default-x-device'."
790 (let* ((name fontname)
791 (device (or device (default-x-device)))
792 (pattern (fc-font-match device (fc-name-parse name)))
793 (font-obj (make-font))
794 (family (fc-pattern-get-family pattern 0))
795 (size (fc-pattern-get-or-compute-size pattern 0))
796 (weight (fc-pattern-get-weight pattern 0)))
797 (set-font-family font-obj
798 (and (not (equal family 'fc-result-no-match))
799 family))
800 (set-font-size font-obj
801 (and (not (equal size 'fc-result-no-match))
802 size))
803 (set-font-weight font-obj
804 (and (not (equal weight 'fc-result-no-match))
805 (fc-font-weight-translate-from-constant weight)))
806 font-obj))
807
808 ;; #### FIXME Xft fonts are not defined by the device.
809 ;; ... Does that mean the whole model here is bogus?
810 (defun xft-font-families-for-device (&optional device no-resetp)
811 (ignore-errors (require 'x-font-menu)) ; #### FIXME xft-font-menu?
723 (or device (setq device (selected-device))) 812 (or device (setq device (selected-device)))
724 (if (boundp 'device-fonts-cache) 813 (if (boundp 'device-fonts-cache) ; #### FIXME does this make sense?
725 (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) 814 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
726 (if (and (not menu) (not no-resetp)) 815 (if (and (not menu) (not no-resetp))
727 (progn 816 (progn
728 (reset-device-font-menus device) 817 (reset-device-font-menus device)
729 (ns-font-families-for-device device t)) 818 (xft-font-families-for-device device t))
819 ;; #### FIXME clearly bogus for Xft
730 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0))) 820 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
731 (aref menu 0))) 821 (aref menu 0)))
732 (normal (mapcar #'(lambda (x) (if x (aref x 0))) 822 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
733 (aref menu 1)))) 823 (aref menu 1))))
734 (sort (font-unique (nconc scaled normal)) 'string-lessp)))))) 824 (sort (delete-duplicates (nconc scaled normal) :test #'equal)
735 825 'string-lessp))))
736 (defun ns-font-create-name (fontobj &optional device) 826 ;; #### FIXME clearly bogus for Xft
737 "Return a font name constructed from FONTOBJ, appropriate for NextSTEP devices." 827 (cons "monospace" (mapcar 'car font-xft-family-mappings))))
738 (let ((family (or (font-family fontobj) 828
739 (ns-font-families-for-device device))) 829 (defun xft-font-create-name (fontobj &optional device)
740 (weight (or (font-weight fontobj) :medium)) 830 (let* ((pattern (make-fc-pattern)))
741 (style (or (font-style fontobj) (list :normal))) 831 (if (font-family fontobj)
742 (size (font-size fontobj))) 832 (fc-pattern-add-family pattern (font-family fontobj)))
743 ;; Create a font, wow! 833 (if (font-size fontobj)
744 (if (stringp family) 834 (fc-pattern-add-size pattern (font-size fontobj)))
745 (setq family (list family))) 835 (fc-name-unparse pattern)))
746 (if (or (symbolp style) (numberp style))
747 (setq style (list style)))
748 (setq weight (font-higher-weight weight (car-safe (memq :bold style))))
749 (if (stringp size)
750 (setq size (font-spatial-to-canonical size device)))
751 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings))
752 "medium"))
753 (let ((done nil) ; Did we find a good font yet?
754 (font-name nil) ; font name we are currently checking
755 (cur-family nil) ; current family we are checking
756 )
757 (while (and family (not done))
758 (setq cur-family (car family)
759 family (cdr family))
760 (if (assoc cur-family font-x-family-mappings)
761 ;; If the family name is an alias as defined by
762 ;; font-x-family-mappings, then append those families
763 ;; to the front of 'family' and continue in the loop.
764 ;; #### jhar: I don't know about ns font names, so using X mappings
765 (setq family (append
766 (cdr-safe (assoc cur-family
767 font-x-family-mappings))
768 family))
769 ;; CARL: Need help here - I am not familiar with the NS font
770 ;; model
771 (setq font-name "UNKNOWN FORMULA GOES HERE"
772 done (try-font-name font-name device))))
773 (if done font-name))))
774 836
775 837
776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 838 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
777 ;;; The window-system dependent code (mswindows-style) 839 ;;; The window-system dependent code (mswindows-style)
778 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 840 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
868 (or device (setq device (selected-device))) 930 (or device (setq device (selected-device)))
869 (let* ((default (font-default-object-for-device device)) 931 (let* ((default (font-default-object-for-device device))
870 (family (or (font-family fontobj) 932 (family (or (font-family fontobj)
871 (font-family default))) 933 (font-family default)))
872 (weight (or (font-weight fontobj) :regular)) 934 (weight (or (font-weight fontobj) :regular))
873 (size (or (if font-running-xemacs 935 (size (or (font-size fontobj)
874 (font-size fontobj))
875 (font-size default))) 936 (font-size default)))
876 (underline-p (font-underline-p fontobj)) 937 (underline-p (font-underline-p fontobj))
877 (strikeout-p (font-strikethru-p fontobj)) 938 (strikeout-p (font-strikethru-p fontobj))
878 (encoding (font-encoding fontobj))) 939 (encoding (font-encoding fontobj)))
879 (if (stringp family) 940 (if (stringp family)
918 encoding "")) 979 encoding ""))
919 done (try-font-name font-name device)))) 980 done (try-font-name font-name device))))
920 (if done font-name))))) 981 (if done font-name)))))
921 982
922 983
923 ;;; Cache building code
924 ;;;###autoload
925 (defun x-font-build-cache (&optional device)
926 (let ((hash-table (make-hash-table :test 'equal :size 15))
927 (fonts (mapcar 'x-font-create-object
928 (font-list "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
929 (plist nil)
930 (cur nil))
931 (while fonts
932 (setq cur (car fonts)
933 fonts (cdr fonts)
934 plist (cl-gethash (car (font-family cur)) hash-table))
935 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
936 (setq plist (plist-put plist 'weights (cons (font-weight cur)
937 (plist-get plist 'weights)))))
938 (if (not (member (font-size cur) (plist-get plist 'sizes)))
939 (setq plist (plist-put plist 'sizes (cons (font-size cur)
940 (plist-get plist 'sizes)))))
941 (if (and (font-oblique-p cur)
942 (not (memq 'oblique (plist-get plist 'styles))))
943 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
944 (if (and (font-italic-p cur)
945 (not (memq 'italic (plist-get plist 'styles))))
946 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
947 (cl-puthash (car (font-family cur)) plist hash-table))
948 hash-table))
949
950
951 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 984 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
952 ;;; Now overwrite the original copy of set-face-font with our own copy that 985 ;;; Now overwrite the original copy of set-face-font with our own copy that
953 ;;; can deal with either syntax. 986 ;;; can deal with either syntax.
954 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 987 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
955 ;;; ###autoload 988 ;;; ###autoload
965 (let (cur) 998 (let (cur)
966 (while font-name 999 (while font-name
967 (setq cur (car font-name) 1000 (setq cur (car font-name)
968 font-name (cdr font-name)) 1001 font-name (cdr font-name))
969 (apply 'set-face-property face (car cur) (cdr cur) args)))) 1002 (apply 'set-face-property face (car cur) (cdr cur) args))))
970 (font-running-xemacs 1003 (t
971 (apply 'set-face-font face font-name args) 1004 (apply 'set-face-font face font-name args)
972 (apply 'set-face-underline-p face (font-underline-p font) args) 1005 (apply 'set-face-underline-p face (font-underline-p font) args)
973 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font)) 1006 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
974 (fboundp 'set-face-display-table)) 1007 (fboundp 'set-face-display-table))
975 (apply 'set-face-display-table 1008 (apply 'set-face-display-table
976 face font-caps-display-table args)) 1009 face font-caps-display-table args))
977 (apply 'set-face-property face 'strikethru (or 1010 (apply 'set-face-property face 'strikethru (or
978 (font-linethrough-p font) 1011 (font-linethrough-p font)
979 (font-strikethru-p font)) 1012 (font-strikethru-p font))
980 args)) 1013 args))
981 (t 1014 ;;; this used to be default with preceding conditioned on font-running-xemacs
982 (condition-case nil 1015 ; (t
983 (apply 'set-face-font face font-name args) 1016 ; (condition-case nil
984 (error 1017 ; (apply 'set-face-font face font-name args)
985 (let ((args (car-safe args))) 1018 ; (error
986 (and (or (font-bold-p font) 1019 ; (let ((args (car-safe args)))
987 (memq (font-weight font) '(:bold :demi-bold))) 1020 ; (and (or (font-bold-p font)
988 (make-face-bold face args t)) 1021 ; (memq (font-weight font) '(:bold :demi-bold)))
989 (and (font-italic-p font) (make-face-italic face args t))))) 1022 ; (make-face-bold face args t))
990 (apply 'set-face-underline-p face (font-underline-p font) args))))) 1023 ; (and (font-italic-p font) (make-face-italic face args t)))))
1024 ; (apply 'set-face-underline-p face (font-underline-p font) args))
1025 )))
991 (t 1026 (t
992 ;; Let the original set-face-font signal any errors 1027 ;; Let the original set-face-font signal any errors
993 (set-face-property face 'font-specification nil) 1028 (set-face-property face 'font-specification nil)
994 (apply 'set-face-font face font args)))) 1029 (apply 'set-face-font face font args))))
995 1030
1057 (defun font-lookup-rgb-components (color) 1092 (defun font-lookup-rgb-components (color)
1058 "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values. 1093 "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
1059 The list (R G B) is returned, or an error is signaled if the lookup fails." 1094 The list (R G B) is returned, or an error is signaled if the lookup fails."
1060 (let ((lib-list (if-boundp 'x-library-search-path 1095 (let ((lib-list (if-boundp 'x-library-search-path
1061 x-library-search-path 1096 x-library-search-path
1062 ;; This default is from XEmacs 19.13 - hope it covers
1063 ;; everyone.
1064 (list "/usr/X11R6/lib/X11/" 1097 (list "/usr/X11R6/lib/X11/"
1065 "/usr/X11R5/lib/X11/" 1098 "/usr/X11R5/lib/X11/"
1066 "/usr/lib/X11R6/X11/" 1099 "/usr/lib/X11R6/X11/"
1067 "/usr/lib/X11R5/X11/" 1100 "/usr/lib/X11R5/X11/"
1068 "/usr/local/X11R6/lib/X11/" 1101 "/usr/local/X11R6/lib/X11/"
1069 "/usr/local/X11R5/lib/X11/" 1102 "/usr/local/X11R5/lib/X11/"
1070 "/usr/local/lib/X11R6/X11/" 1103 "/usr/local/lib/X11R6/X11/"
1071 "/usr/local/lib/X11R5/X11/" 1104 "/usr/local/lib/X11R5/X11/"
1072 "/usr/X11/lib/X11/" 1105 "/usr/X11/lib/X11/"
1073 "/usr/lib/X11/" 1106 "/usr/lib/X11/"
1107 "/usr/share/X11/"
1074 "/usr/local/lib/X11/" 1108 "/usr/local/lib/X11/"
1109 "/usr/local/share/X11/"
1075 "/usr/X386/lib/X11/" 1110 "/usr/X386/lib/X11/"
1076 "/usr/x386/lib/X11/" 1111 "/usr/x386/lib/X11/"
1077 "/usr/XFree86/lib/X11/" 1112 "/usr/XFree86/lib/X11/"
1078 "/usr/unsupported/lib/X11/" 1113 "/usr/unsupported/lib/X11/"
1079 "/usr/athena/lib/X11/" 1114 "/usr/athena/lib/X11/"
1360 found)) 1395 found))
1361 1396
1362 (defun font-blink-callback () 1397 (defun font-blink-callback ()
1363 ;; Optimized to never invert the face unless one of the visible windows 1398 ;; Optimized to never invert the face unless one of the visible windows
1364 ;; is showing it. 1399 ;; is showing it.
1365 (let ((faces (if font-running-xemacs (face-list t) (face-list))) 1400 (let ((faces (face-list t))
1366 (obj nil)) 1401 (obj nil))
1367 (while faces 1402 (while faces
1368 (if (and (setq obj (face-property (car faces) 'font-specification)) 1403 (if (and (setq obj (face-property (car faces) 'font-specification))
1369 (font-blink-p obj) 1404 (font-blink-p obj)
1370 (memq t 1405 (memq t
1371 (font-map-windows 'font-face-visible-in-window-p (car faces)))) 1406 (font-map-windows 'font-face-visible-in-window-p
1407 (car faces))))
1372 (invert-face (car faces))) 1408 (invert-face (car faces)))
1373 (pop faces)))) 1409 (pop faces))))
1374 1410
1375 (defcustom font-blink-interval 0.5 1411 (defcustom font-blink-interval 0.5
1376 "How often to blink faces" 1412 "How often to blink faces"