Mercurial > hg > xemacs-beta

comparison lisp/font.el @ 3094:ad2f4ae9895b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2005-11-26 11:45:47 by stephent] Xft merge. <87k6ev4p8q.fsf@tleepslib.sk.tsukuba.ac.jp>
author stephent
date Sat, 26 Nov 2005 11:46:25 +0000
parents 64752935473d
children d97bc868eaaf
comparison
equal deleted inserted replaced
3093:769dc945b085 3094:ad2f4ae9895b
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
40 font-warn)) 52 font-warn))
41 53
42 (globally-declare-boundp 54 (globally-declare-boundp
43 '(global-face-data 55 '(global-face-data
44 x-font-regexp x-font-regexp-foundry-and-family 56 x-font-regexp x-font-regexp-foundry-and-family
57 fc-font-regexp
45 mswindows-font-regexp)) 58 mswindows-font-regexp))
46 59
47 (require 'cl) 60 (require 'cl)
48 61
49 (eval-and-compile 62 (eval-and-compile
87 100
88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
89 ;;; Lots of variables / keywords for use later in the program 102 ;;; Lots of variables / keywords for use later in the program
90 ;;; Not much should need to be modified 103 ;;; Not much should need to be modified
91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
92 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version)) 105 ;; #### 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 106 (defconst font-window-system-mappings
104 '((x . (x-font-create-name x-font-create-object)) 107 '((x . (x-font-create-name x-font-create-object))
105 (gtk . (x-font-create-name x-font-create-object)) 108 (gtk . (x-font-create-name x-font-create-object))
109 ;; #### FIXME should this handle fontconfig font objects?
110 (fc . (fc-font-create-name fc-font-create-object))
106 (ns . (ns-font-create-name ns-font-create-object)) 111 (ns . (ns-font-create-name ns-font-create-object))
107 (mswindows . (mswindows-font-create-name mswindows-font-create-object)) 112 (mswindows . (mswindows-font-create-name mswindows-font-create-object))
108 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME 113 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
114 ;; #### what is this bogosity?
109 (tty . (tty-font-create-plist tty-font-create-object))) 115 (tty . (tty-font-create-plist tty-font-create-object)))
110 "An assoc list mapping device types to a list of translations. 116 "An assoc list mapping device types to a list of translations.
111 117
112 The first function creates a font name from a font descriptor object. 118 The first function creates a font name from a font descriptor object.
113 The second performs the reverse translation.") 119 The second performs the reverse translation.")
146 152
147 (defvar font-maximum-slippage "1pt" 153 (defvar font-maximum-slippage "1pt"
148 "How much a font is allowed to vary from the desired size.") 154 "How much a font is allowed to vary from the desired size.")
149 155
150 ;; Canonical (internal) sizes are in points. 156 ;; Canonical (internal) sizes are in points.
151 ;; Registry 157
152 (define-font-keywords :family :style :size :registry :encoding) 158 ;; Property keywords: :family :style :size :registry :encoding :weight
153 159 ;; Weight keywords: :extra-light :light :demi-light :medium
154 (define-font-keywords 160 ;; :normal :demi-bold :bold :extra-bold
155 :weight :extra-light :light :demi-light :medium :normal :demi-bold 161 ;; See GNU Emacs 21.4 for more properties and keywords we should support
156 :bold :extra-bold)
157 162
158 (defvar font-style-keywords nil) 163 (defvar font-style-keywords nil)
159 164
160 (defun set-font-family (fontobj family) 165 (defun set-font-family (fontobj family)
161 (aset fontobj 1 family)) 166 (aset fontobj 1 family))
246 ;; Standard ASCII characters 251 ;; Standard ASCII characters
247 (while (< i 26) 252 (while (< i 26)
248 (aset table (+ i ?a) (+ i ?A)) 253 (aset table (+ i ?a) (+ i ?A))
249 (setq i (1+ i))) 254 (setq i (1+ i)))
250 ;; Now ISO translations 255 ;; Now ISO translations
256 ;; #### FIXME what's this for??
251 (setq i 224) 257 (setq i 224)
252 (while (< i 247) ;; Agrave - Ouml 258 (while (< i 247) ;; Agrave - Ouml
253 (aset table i (- i 32)) 259 (aset table i (- i 32))
254 (setq i (1+ i))) 260 (setq i (1+ i)))
255 (setq i 248) 261 (setq i 248)
259 table)) 265 table))
260 266
261 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
262 ;;; Utility functions 268 ;;; Utility functions
263 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 269 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
264 (defun set-font-style-by-keywords (fontobj styles) 270 ;; #### unused?
265 (make-local-variable 'font-func) 271 ; (defun set-font-style-by-keywords (fontobj styles)
266 (declare (special font-func)) 272 ; (make-local-variable 'font-func)
267 (if (listp styles) 273 ; (declare (special font-func))
268 (while styles 274 ; (if (listp styles)
269 (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords))) 275 ; (while styles
270 styles (cdr styles)) 276 ; (setq font-func (car-safe (cdr-safe (assq (car styles)
271 (and (fboundp font-func) (funcall font-func fontobj t))) 277 ; font-style-keywords)))
272 (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords)))) 278 ; styles (cdr styles))
273 (and (fboundp font-func) (funcall font-func fontobj t)))) 279 ; (and (fboundp font-func) (funcall font-func fontobj t)))
274 280 ; (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
275 (defun font-properties-from-style (fontobj) 281 ; (and (fboundp font-func) (funcall font-func fontobj t))))
276 (let ((todo font-style-keywords) 282
277 type func retval) 283 ;; #### unused?
278 (while todo 284 ; (defun font-properties-from-style (fontobj)
279 (setq func (cdr (cdr (car todo))) 285 ; (let ((todo font-style-keywords)
280 type (car (pop todo))) 286 ; type func retval)
281 (if (funcall func fontobj) 287 ; (while todo
282 (setq retval (cons type retval)))) 288 ; (setq func (cdr (cdr (car todo)))
283 retval)) 289 ; type (car (pop todo)))
284 290 ; (if (funcall func fontobj)
291 ; (setq retval (cons type retval))))
292 ; retval))
293
294 ;; #### only used in this file; maybe there's a cl.el function?
285 (defun font-unique (list) 295 (defun font-unique (list)
286 (let ((retval) 296 (let ((retval)
287 (cur)) 297 (cur))
288 (while list 298 (while list
289 (setq cur (car list) 299 (setq cur (car list)
327 ;; to 1024x768 resolution on a 17" screen 337 ;; to 1024x768 resolution on a 17" screen
328 (pix-width (float (or (device-pixel-width device) 1024))) 338 (pix-width (float (or (device-pixel-width device) 1024)))
329 (mm-width (float (or (device-mm-width device) 293))) 339 (mm-width (float (or (device-mm-width device) 293)))
330 (retval nil)) 340 (retval nil))
331 (cond 341 (cond
332 ;; the following string-match is broken, there will never be a 342 ;; #### this is pretty bogus and should probably be made gone
333 ;; left operand detected 343 ;; or supported at a higher level
334 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee! 344 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee!
335 (let ((math-func (intern (match-string 1 spec))) 345 (let ((math-func (intern (match-string 1 spec)))
336 (other (font-spatial-to-canonical 346 (other (font-spatial-to-canonical
337 (substring spec (match-end 0) nil))) 347 (substring spec (match-end 0) nil)))
338 (default (font-spatial-to-canonical 348 (default (font-spatial-to-canonical
359 ((member type '("inch" "in")) 369 ((member type '("inch" "in"))
360 (setq retval (* num 72.0))) 370 (setq retval (* num 72.0)))
361 ((string= type "mm") 371 ((string= type "mm")
362 (setq retval (* num (/ 72.0 25.4)))) 372 (setq retval (* num (/ 72.0 25.4))))
363 ((string= type "cm") 373 ((string= type "cm")
364 (setq retval (* num 10 (/ 72.0 25.4)))) 374 (setq retval (* num (/ 72.0 2.54))))
365 (t 375 (t
366 (setq retval num)) 376 (setq retval num))
367 ) 377 )
368 retval)))) 378 retval))))
369 379
443 (while args 453 (while args
444 (setq retval (font-combine-fonts-internal retval (car args)) 454 (setq retval (font-combine-fonts-internal retval (car args))
445 args (cdr args))) 455 args (cdr args)))
446 retval)))) 456 retval))))
447 457
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
448 494
449 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 495 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
450 ;;; The window-system dependent code (TTY-style) 496 ;;; The window-system dependent code (TTY-style)
451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 497 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
452 (defun tty-font-create-object (fontname &optional device) 498 (defun tty-font-create-object (fontname &optional device)
466 512
467 513
468 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 514 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
469 ;;; The window-system dependent code (X-style) 515 ;;; The window-system dependent code (X-style)
470 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
471 (defvar font-x-font-regexp (or (and font-running-xemacs 517 (defvar font-x-font-regexp (when (and (boundp 'x-font-regexp)
472 (boundp 'x-font-regexp) 518 x-font-regexp)
473 x-font-regexp)
474 (let 519 (let
475 ((- "[-?]") 520 ((- "[-?]")
476 (foundry "[^-]*") 521 (foundry "[^-]*")
477 (family "[^-]*") 522 (family "[^-]*")
478 ;(weight "\\(bold\\|demibold\\|medium\\|black\\)") 523 ;(weight "\\(bold\\|demibold\\|medium\\|black\\)")
495 pixelsize - pointsize - resx - resy - spacing - avgwidth - 540 pixelsize - pointsize - resx - resy - spacing - avgwidth -
496 registry - encoding "\\'" 541 registry - encoding "\\'"
497 )))) 542 ))))
498 543
499 (defvar font-x-registry-and-encoding-regexp 544 (defvar font-x-registry-and-encoding-regexp
500 (or (and font-running-xemacs 545 (when (and (boundp 'x-font-regexp-registry-and-encoding)
501 (boundp 'x-font-regexp-registry-and-encoding) 546 (symbol-value 'x-font-regexp-registry-and-encoding))
502 (symbol-value 'x-font-regexp-registry-and-encoding)) 547 (let ((- "[-?]")
503 (let ((- "[-?]") 548 (registry "[^-]*")
504 (registry "[^-]*") 549 (encoding "[^-]+"))
505 (encoding "[^-]+")) 550 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
506 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
507 551
508 (defvar font-x-family-mappings 552 (defvar font-x-family-mappings
509 '( 553 '(
510 ("serif" . ("new century schoolbook" 554 ("serif" . ("new century schoolbook"
511 "utopia" 555 "utopia"
598 (normal (mapcar #'(lambda (x) (if x (aref x 0))) 642 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
599 (aref menu 1)))) 643 (aref menu 1))))
600 (sort (font-unique (nconc scaled normal)) 'string-lessp)))) 644 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
601 (cons "monospace" (mapcar 'car font-x-family-mappings)))) 645 (cons "monospace" (mapcar 'car font-x-family-mappings))))
602 646
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
644 (defun x-font-create-name (fontobj &optional device) 647 (defun x-font-create-name (fontobj &optional device)
645 "Return a font name constructed from FONTOBJ, appropriate for X devices." 648 "Return a font name constructed from FONTOBJ, appropriate for X devices."
646 (if (and (not (or (font-family fontobj) 649 (if (and (not (or (font-family fontobj)
647 (font-weight fontobj) 650 (font-weight fontobj)
648 (font-size fontobj) 651 (font-size fontobj)
654 (let* ((default (font-default-object-for-device device)) 657 (let* ((default (font-default-object-for-device device))
655 (family (or (font-family fontobj) 658 (family (or (font-family fontobj)
656 (font-family default) 659 (font-family default)
657 (x-font-families-for-device device))) 660 (x-font-families-for-device device)))
658 (weight (or (font-weight fontobj) :medium)) 661 (weight (or (font-weight fontobj) :medium))
659 (size (or (if font-running-xemacs 662 (size (or (font-size fontobj)
660 (font-size fontobj))
661 (font-size default))) 663 (font-size default)))
662 (registry (or (font-registry fontobj) 664 (registry (or (font-registry fontobj)
663 (font-registry default) 665 (font-registry default)
664 "*")) 666 "*"))
665 (encoding (or (font-encoding fontobj) 667 (encoding (or (font-encoding fontobj)
712 slants (cdr slants) 714 slants (cdr slants)
713 done (try-font-name font-name device)))))) 715 done (try-font-name font-name device))))))
714 (if done font-name))))) 716 (if done font-name)))))
715 717
716 718
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)
799 "Return a font descriptor object for FONTNAME, appropriate for Xft."
800 (let* ((name fontname)
801 (device (or device (default-x-device)))
802 (pattern (fc-font-real-pattern name device))
803 (font-obj (make-font))
804 (family (fc-pattern-get-family pattern 0))
805 (size (fc-pattern-get-size pattern 0))
806 (weight (fc-pattern-get-weight pattern 0)))
807 (set-font-family font-obj
808 (and (not (equal family 'fc-result-no-match))
809 family))
810 (set-font-size font-obj
811 (and (not (equal size 'fc-result-no-match))
812 size))
813 (set-font-weight font-obj
814 (and (not (equal weight 'fc-result-no-match))
815 (fc-font-weight-translate-from-constant weight)))
816 font-obj))
817
818 ;; #### FIXME Xft fonts are not defined by the device.
819 ;; ... Does that mean the whole model here is bogus?
820 (defun xft-font-families-for-device (&optional device no-resetp)
821 (ignore-errors (require 'x-font-menu)) ; #### FIXME xft-font-menu?
822 (or device (setq device (selected-device)))
823 (if (boundp 'device-fonts-cache) ; #### FIXME does this make sense?
824 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
825 (if (and (not menu) (not no-resetp))
826 (progn
827 (reset-device-font-menus device)
828 (xft-font-families-for-device device t))
829 ;; #### FIXME clearly bogus for Xft
830 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
831 (aref menu 0)))
832 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
833 (aref menu 1))))
834 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
835 ;; #### FIXME clearly bogus for Xft
836 (cons "monospace" (mapcar 'car font-xft-family-mappings))))
837
838 (defun xft-font-create-name (fontobj &optional device)
839 (let* ((pattern (make-fc-pattern)))
840 (if (font-family fontobj)
841 (fc-pattern-add-family pattern (font-family fontobj)))
842 (if (font-size fontobj)
843 (fc-pattern-add-size pattern (font-size fontobj)))
844 (fc-name-unparse pattern)))
845
846
717 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 847 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
718 ;;; The window-system dependent code (NS-style) 848 ;;; The window-system dependent code (NS-style)
719 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 849 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
720 (defun ns-font-families-for-device (&optional device no-resetp) 850 (defun ns-font-families-for-device (&optional device no-resetp)
721 ;; For right now, assume we are going to have the same storage for 851 ;; For right now, assume we are going to have the same storage for
868 (or device (setq device (selected-device))) 998 (or device (setq device (selected-device)))
869 (let* ((default (font-default-object-for-device device)) 999 (let* ((default (font-default-object-for-device device))
870 (family (or (font-family fontobj) 1000 (family (or (font-family fontobj)
871 (font-family default))) 1001 (font-family default)))
872 (weight (or (font-weight fontobj) :regular)) 1002 (weight (or (font-weight fontobj) :regular))
873 (size (or (if font-running-xemacs 1003 (size (or (font-size fontobj)
874 (font-size fontobj))
875 (font-size default))) 1004 (font-size default)))
876 (underline-p (font-underline-p fontobj)) 1005 (underline-p (font-underline-p fontobj))
877 (strikeout-p (font-strikethru-p fontobj)) 1006 (strikeout-p (font-strikethru-p fontobj))
878 (encoding (font-encoding fontobj))) 1007 (encoding (font-encoding fontobj)))
879 (if (stringp family) 1008 (if (stringp family)
918 encoding "")) 1047 encoding ""))
919 done (try-font-name font-name device)))) 1048 done (try-font-name font-name device))))
920 (if done font-name))))) 1049 (if done font-name)))))
921 1050
922 1051
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1052 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
952 ;;; Now overwrite the original copy of set-face-font with our own copy that 1053 ;;; Now overwrite the original copy of set-face-font with our own copy that
953 ;;; can deal with either syntax. 1054 ;;; can deal with either syntax.
954 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1055 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
955 ;;; ###autoload 1056 ;;; ###autoload
965 (let (cur) 1066 (let (cur)
966 (while font-name 1067 (while font-name
967 (setq cur (car font-name) 1068 (setq cur (car font-name)
968 font-name (cdr font-name)) 1069 font-name (cdr font-name))
969 (apply 'set-face-property face (car cur) (cdr cur) args)))) 1070 (apply 'set-face-property face (car cur) (cdr cur) args))))
970 (font-running-xemacs 1071 (t
971 (apply 'set-face-font face font-name args) 1072 (apply 'set-face-font face font-name args)
972 (apply 'set-face-underline-p face (font-underline-p font) args) 1073 (apply 'set-face-underline-p face (font-underline-p font) args)
973 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font)) 1074 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
974 (fboundp 'set-face-display-table)) 1075 (fboundp 'set-face-display-table))
975 (apply 'set-face-display-table 1076 (apply 'set-face-display-table
976 face font-caps-display-table args)) 1077 face font-caps-display-table args))
977 (apply 'set-face-property face 'strikethru (or 1078 (apply 'set-face-property face 'strikethru (or
978 (font-linethrough-p font) 1079 (font-linethrough-p font)
979 (font-strikethru-p font)) 1080 (font-strikethru-p font))
980 args)) 1081 args))
981 (t 1082 ;;; this used to be default with preceding conditioned on font-running-xemacs
982 (condition-case nil 1083 ; (t
983 (apply 'set-face-font face font-name args) 1084 ; (condition-case nil
984 (error 1085 ; (apply 'set-face-font face font-name args)
985 (let ((args (car-safe args))) 1086 ; (error
986 (and (or (font-bold-p font) 1087 ; (let ((args (car-safe args)))
987 (memq (font-weight font) '(:bold :demi-bold))) 1088 ; (and (or (font-bold-p font)
988 (make-face-bold face args t)) 1089 ; (memq (font-weight font) '(:bold :demi-bold)))
989 (and (font-italic-p font) (make-face-italic face args t))))) 1090 ; (make-face-bold face args t))
990 (apply 'set-face-underline-p face (font-underline-p font) args))))) 1091 ; (and (font-italic-p font) (make-face-italic face args t)))))
1092 ; (apply 'set-face-underline-p face (font-underline-p font) args))
1093 )))
991 (t 1094 (t
992 ;; Let the original set-face-font signal any errors 1095 ;; Let the original set-face-font signal any errors
993 (set-face-property face 'font-specification nil) 1096 (set-face-property face 'font-specification nil)
994 (apply 'set-face-font face font args)))) 1097 (apply 'set-face-font face font args))))
995 1098
1360 found)) 1463 found))
1361 1464
1362 (defun font-blink-callback () 1465 (defun font-blink-callback ()
1363 ;; Optimized to never invert the face unless one of the visible windows 1466 ;; Optimized to never invert the face unless one of the visible windows
1364 ;; is showing it. 1467 ;; is showing it.
1365 (let ((faces (if font-running-xemacs (face-list t) (face-list))) 1468 (let ((faces (face-list t))
1366 (obj nil)) 1469 (obj nil))
1367 (while faces 1470 (while faces
1368 (if (and (setq obj (face-property (car faces) 'font-specification)) 1471 (if (and (setq obj (face-property (car faces) 'font-specification))
1369 (font-blink-p obj) 1472 (font-blink-p obj)
1370 (memq t 1473 (memq t
1371 (font-map-windows 'font-face-visible-in-window-p (car faces)))) 1474 (font-map-windows 'font-face-visible-in-window-p
1475 (car faces))))
1372 (invert-face (car faces))) 1476 (invert-face (car faces)))
1373 (pop faces)))) 1477 (pop faces))))
1374 1478
1375 (defcustom font-blink-interval 0.5 1479 (defcustom font-blink-interval 0.5
1376 "How often to blink faces" 1480 "How often to blink faces"