Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 80:1ce6082ce73f r20-0b90

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b90
author cvs
date Mon, 13 Aug 2007 09:06:37 +0200
parents 131b0175ea99
children 6a378aca36af
comparison
equal deleted inserted replaced
79:5b0a5bbffab6 80:1ce6082ce73f
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1996/08/11 16:40:36 3 ;; Created: 1997/01/03 16:43:49
4 ;; Version: 1.8 4 ;; Version: 1.22
5 ;; Keywords: faces 5 ;; Keywords: faces
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996 Free Software Foundation, Inc.
9 ;;; 10 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply. 11 ;;; This file is part of GNU Emacs.
11 ;;; 12 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify 13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by 14 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2, or (at your option) 15 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version. 16 ;;; any later version.
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details. 21 ;;; GNU General Public License for more details.
21 ;;; 22 ;;;
22 ;;; You should have received a copy of the GNU General Public License 23 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to 24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 28
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; The emacsen compatibility package - load it up before anything else 30 ;;; The emacsen compatibility package - load it up before anything else
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (eval-and-compile 32 (eval-and-compile
31 (load-library "w3-sysdp") 33 (require 'w3-sysdp)
32 (require 'cl)) 34 (require 'cl))
33 35
34 (require 'disp-table) 36 (require 'disp-table)
35 (if (not (fboundp '<<)) (fset '<< 'lsh)) 37 (if (not (fboundp '<<)) (fset '<< 'lsh))
36 (if (not (fboundp '&)) (fset '& 'logand)) 38 (if (not (fboundp '&)) (fset '& 'logand))
140 (defkeyword :style "Keyword specifying the font style of a FONTOBJ.") 142 (defkeyword :style "Keyword specifying the font style of a FONTOBJ.")
141 (defkeyword :size "Keyword specifying the font size of a FONTOBJ.") 143 (defkeyword :size "Keyword specifying the font size of a FONTOBJ.")
142 (defkeyword :registry "Keyword specifying the registry of a FONTOBJ.") 144 (defkeyword :registry "Keyword specifying the registry of a FONTOBJ.")
143 (defkeyword :encoding "Keyword specifying the encoding of a FONTOBJ.") 145 (defkeyword :encoding "Keyword specifying the encoding of a FONTOBJ.")
144 146
147 (defvar font-style-keywords nil)
148
149 (defsubst set-font-family (fontobj family)
150 (aset fontobj 1 family))
151
152 (defsubst set-font-weight (fontobj weight)
153 (aset fontobj 3 weight))
154
155 (defsubst set-font-style (fontobj style)
156 (aset fontobj 5 style))
157
158 (defsubst set-font-size (fontobj size)
159 (aset fontobj 7 size))
160
161 (defsubst set-font-registry (fontobj reg)
162 (aset fontobj 9 reg))
163
164 (defsubst set-font-encoding (fontobj enc)
165 (aset fontobj 11 enc))
166
167 (defsubst font-family (fontobj)
168 (aref fontobj 1))
169
170 (defsubst font-weight (fontobj)
171 (aref fontobj 3))
172
173 (defsubst font-style (fontobj)
174 (aref fontobj 5))
175
176 (defsubst font-size (fontobj)
177 (aref fontobj 7))
178
179 (defsubst font-registry (fontobj)
180 (aref fontobj 9))
181
182 (defsubst font-encoding (fontobj)
183 (aref fontobj 11))
184
145 (eval-when-compile 185 (eval-when-compile
146 (defmacro define-new-mask (attr mask) 186 (defmacro define-new-mask (attr mask)
147 (` 187 (`
148 (progn 188 (progn
189 (setq font-style-keywords
190 (cons (cons (quote (, attr))
191 (cons
192 (quote (, (intern (format "set-font-%s-p" attr))))
193 (quote (, (intern (format "font-%s-p" attr))))))
194 font-style-keywords))
149 (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask)) 195 (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask))
150 (, (format 196 (, (format
151 "Bitmask for whether a font is to be rendered in %s or not." 197 "Bitmask for whether a font is to be rendered in %s or not."
152 attr))) 198 attr)))
153 (defun (, (intern (format "font-%s-p" attr))) (fontobj) 199 (defun (, (intern (format "font-%s-p" attr))) (fontobj)
154 (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr)) 200 (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr))
155 (if (/= 0 (& (font-style fontobj) 201 (if (/= 0 (& (font-style fontobj)
156 (, (intern (format "font-%s-mask" attr))))) 202 (, (intern (format "font-%s-mask" attr)))))
157 t 203 t
158 nil)) 204 nil))
159 (defun (, (intern (format "font-set-%s-p" attr))) (fontobj val) 205 (defun (, (intern (format "set-font-%s-p" attr))) (fontobj val)
160 (, (format "Set whether FONTOBJ will be renderd in `%s' or not." 206 (, (format "Set whether FONTOBJ will be renderd in `%s' or not."
161 attr)) 207 attr))
162 (if val 208 (cond
163 (set-font-style fontobj (| (font-style fontobj) 209 (val
164 (, (intern 210 (set-font-style fontobj (| (font-style fontobj)
165 (format "font-%s-mask" attr))))) 211 (, (intern
166 (set-font-style fontobj (logxor (font-style fontobj) 212 (format "font-%s-mask" attr))))))
167 (, (intern 213 (((, (intern (format "font-%s-p" attr))) fontobj)
168 (format "font-%s-mask" 214 (set-font-style fontobj (- (font-style fontobj)
169 attr))))))) 215 (, (intern
216 (format "font-%s-mask" attr))))))))
170 )))) 217 ))))
171 218
172 (let ((mask 0)) 219 (let ((mask 0))
173 (define-new-mask bold (setq mask (1+ mask))) 220 (define-new-mask bold (setq mask (1+ mask)))
174 (define-new-mask italic (setq mask (1+ mask))) 221 (define-new-mask italic (setq mask (1+ mask)))
203 table)) 250 table))
204 251
205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 252 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
206 ;;; Utility functions 253 ;;; Utility functions
207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
255 (defsubst set-font-style-by-keywords (fontobj styles)
256 (make-local-variable 'font-func)
257 (declare (special font-func))
258 (while styles
259 (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords)))
260 styles (cdr styles))
261 (and (fboundp font-func) (funcall font-func fontobj t))))
262
263 (defsubst font-properties-from-style (fontobj)
264 (let ((style (font-style fontobj))
265 (todo font-style-keywords)
266 type func retval)
267 (while todo
268 (setq func (cdr (cdr (car todo)))
269 type (car (pop todo)))
270 (if (funcall func fontobj)
271 (setq retval (cons type retval))))
272 retval))
273
208 (defun unique (list) 274 (defun unique (list)
209 (let ((retval) 275 (let ((retval)
210 (cur)) 276 (cur))
211 (while list 277 (while list
212 (setq cur (car list) 278 (setq cur (car list)
226 w1) 292 w1)
227 (t 293 (t
228 w2)))) 294 w2))))
229 295
230 (defun font-spatial-to-canonical (spec &optional device) 296 (defun font-spatial-to-canonical (spec &optional device)
231 "Convert SPEC (in inches, millimeters, points, or picas) into pixels" 297 "Convert SPEC (in inches, millimeters, points, or picas) into points"
232 ;; 1 in = 25.4 mm = 72 pt = 6 pa 298 ;; 1 in = 6 pa = 25.4 mm = 72 pt
233 (if (numberp spec) 299 (if (numberp spec)
234 spec 300 spec
235 (let ((num nil) 301 (let ((num nil)
236 (type nil) 302 (type nil)
237 ;; If for any reason we get null for any of this, default 303 ;; If for any reason we get null for any of this, default
258 (setq type "px" 324 (setq type "px"
259 spec spec))) 325 spec spec)))
260 (setq num (string-to-number spec)) 326 (setq num (string-to-number spec))
261 (cond 327 (cond
262 ((member type '("pixel" "px" "pix")) 328 ((member type '("pixel" "px" "pix"))
263 (setq retval num 329 (setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0))))
264 num nil))
265 ((member type '("point" "pt")) 330 ((member type '("point" "pt"))
266 (setq retval (+ (* (/ pix-width mm-width) 331 (setq retval num))
267 (/ 25.4 72.0)
268 num))))
269 ((member type '("pica" "pa")) 332 ((member type '("pica" "pa"))
270 (setq retval (* (/ pix-width mm-width) 333 (setq retval (* num 12.0)))
271 (/ 25.4 6.0)
272 num)))
273 ((member type '("inch" "in")) 334 ((member type '("inch" "in"))
274 (setq retval (* (/ pix-width mm-width) 335 (setq retval (* num 72.0)))
275 (/ 25.4 1.0)
276 num)))
277 ((string= type "mm") 336 ((string= type "mm")
278 (setq retval (* (/ pix-width mm-width) 337 (setq retval (* num (/ 72.0 25.4))))
279 num)))
280 ((string= type "cm") 338 ((string= type "cm")
281 (setq retval (* (/ pix-width mm-width) 339 (setq retval (* num 10 (/ 72.0 25.4))))
282 10 340 (t
283 num))) 341 (setq retval num))
284 (t (setq retval num))
285 ) 342 )
286 retval))) 343 retval)))
287 344
288 345
289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 346 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290 ;;; The main interface routines - constructors and accessor functions 347 ;;; The main interface routines - constructors and accessor functions
291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 348 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
292 (defun make-font (&rest args) 349 (defun make-font (&rest args)
293 (vector :family 350 (vector :family
294 (if (stringp (nth 1 (memq :family args))) 351 (if (stringp (plist-get args :family))
295 (list (nth 1 (memq :family args))) 352 (list (plist-get args :family))
296 (nth 1 (memq :family args))) 353 (plist-get args :family))
297 :weight 354 :weight
298 (nth 1 (memq :weight args)) 355 (plist-get args :weight)
299 :style 356 :style
300 (if (numberp (nth 1 (memq :style args))) 357 (if (numberp (plist-get args :style))
301 (nth 1 (memq :style args)) 358 (plist-get args :style)
302 0) 359 0)
303 :size 360 :size
304 (nth 1 (memq :size args)) 361 (plist-get args :size)
305 :registry 362 :registry
306 (nth 1 (memq :registry args)) 363 (plist-get args :registry)
307 :encoding 364 :encoding
308 (nth 1 (memq :encoding args)))) 365 (plist-get args :encoding)))
309
310 (defsubst set-font-family (fontobj family)
311 (aset fontobj 1 family))
312
313 (defsubst set-font-weight (fontobj weight)
314 (aset fontobj 3 weight))
315
316 (defsubst set-font-style (fontobj style)
317 (aset fontobj 5 style))
318
319 (defsubst set-font-size (fontobj size)
320 (aset fontobj 7 size))
321
322 (defsubst set-font-registry (fontobj reg)
323 (aset fontobj 9 reg))
324
325 (defsubst set-font-encoding (fontobj enc)
326 (aset fontobj 11 enc))
327
328 (defsubst font-family (fontobj)
329 (aref fontobj 1))
330
331 (defsubst font-weight (fontobj)
332 (aref fontobj 3))
333
334 (defsubst font-style (fontobj)
335 (aref fontobj 5))
336
337 (defsubst font-size (fontobj)
338 (aref fontobj 7))
339
340 (defsubst font-registry (fontobj)
341 (aref fontobj 9))
342
343 (defsubst font-encoding (fontobj)
344 (aref fontobj 11))
345 366
346 (defun font-create-name (fontobj &optional device) 367 (defun font-create-name (fontobj &optional device)
347 (let* ((type (device-type device)) 368 (let* ((type (device-type device))
348 (func (car (cdr-safe (assq type font-window-system-mappings))))) 369 (func (car (cdr-safe (assq type font-window-system-mappings)))))
349 (and func (fboundp func) (funcall func fontobj device)))) 370 (and func (fboundp func) (funcall func fontobj device))))
398 419
399 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 420 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
400 ;;; The window-system dependent code (TTY-style) 421 ;;; The window-system dependent code (TTY-style)
401 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 422 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
402 (defun tty-font-create-object (fontname &optional device) 423 (defun tty-font-create-object (fontname &optional device)
403 ) 424 (make-font :size "12pt"))
404 425
405 (defun tty-font-create-plist (fontobj &optional device) 426 (defun tty-font-create-plist (fontobj &optional device)
406 (let ((styles (font-style fontobj)) 427 (let ((styles (font-style fontobj))
407 (weight (font-weight fontobj))) 428 (weight (font-weight fontobj)))
408 (list 429 (list
461 (retval nil) 482 (retval nil)
462 (case-fold-search t) 483 (case-fold-search t)
463 ) 484 )
464 (if (not (string-match x-font-regexp-foundry-and-family fontname)) 485 (if (not (string-match x-font-regexp-foundry-and-family fontname))
465 nil 486 nil
466 (setq family (list (match-string 1 fontname)))) 487 (setq family (list (downcase (match-string 1 fontname)))))
467 (if (string= "*" weight) (setq weight nil)) 488 (if (string= "*" weight) (setq weight nil))
468 (if (string= "*" slant) (setq slant nil)) 489 (if (string= "*" slant) (setq slant nil))
469 (if (string= "*" swidth) (setq swidth nil)) 490 (if (string= "*" swidth) (setq swidth nil))
470 (if (string= "*" adstyle) (setq adstyle nil)) 491 (if (string= "*" adstyle) (setq adstyle nil))
471 (if (string= "*" pxsize) (setq pxsize nil)) 492 (if (string= "*" pxsize) (setq pxsize nil))
472 (if (string= "*" ptsize) (setq ptsize nil)) 493 (if (string= "*" ptsize) (setq ptsize nil))
473 (if ptsize (setq size (format "%dpt" (/ (string-to-int ptsize) 10)))) 494 (if ptsize (setq size (/ (string-to-int ptsize) 10)))
474 (if (and (not size) pxsize) (setq size (concat pxsize "px"))) 495 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
475 (if weight (setq weight (intern-soft (concat ":" (downcase weight))))) 496 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
476 (if (and adstyle (not (equal adstyle ""))) 497 (if (and adstyle (not (equal adstyle "")))
477 (setq family (append family (list adstyle)))) 498 (setq family (append family (list (downcase adstyle)))))
478 (setq retval (make-font :family family 499 (setq retval (make-font :family family
479 :weight weight 500 :weight weight
480 :size size)) 501 :size size))
481 (font-set-bold-p retval (eq :bold weight)) 502 (set-font-bold-p retval (eq :bold weight))
482 (cond 503 (cond
483 ((null slant) nil) 504 ((null slant) nil)
484 ((member slant '("i" "I")) 505 ((member slant '("i" "I"))
485 (font-set-italic-p retval t)) 506 (set-font-italic-p retval t))
486 ((member slant '("o" "O")) 507 ((member slant '("o" "O"))
487 (font-set-oblique-p retval t))) 508 (set-font-oblique-p retval t)))
488 retval))) 509 retval)))
489 510
490 (defun x-font-families-for-device (&optional device no-resetp) 511 (defun x-font-families-for-device (&optional device no-resetp)
491 (condition-case () 512 (condition-case ()
492 (require 'x-font-menu) 513 (require 'x-font-menu)
511 (or device (setq device (selected-device))) 532 (or device (setq device (selected-device)))
512 (if font-running-xemacs 533 (if font-running-xemacs
513 (font-truename 534 (font-truename
514 (make-font-specifier 535 (make-font-specifier
515 (face-font-name 'default device))) 536 (face-font-name 'default device)))
516 (cdr-safe (assq 'font (frame-parameters device))))) 537 (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
517 538 (if (and (fboundp 'fontsetp) (fontsetp font))
539 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
540 font))))
541
518 (defun font-default-object-for-device (&optional device) 542 (defun font-default-object-for-device (&optional device)
519 (let ((font (font-default-font-for-device device))) 543 (let ((font (font-default-font-for-device device)))
520 (or (cdr-safe 544 (or (cdr-safe
521 (assoc font font-default-cache)) 545 (assoc font font-default-cache))
522 (progn 546 (progn
541 (font-weight fontobj) 565 (font-weight fontobj)
542 (font-size fontobj) 566 (font-size fontobj)
543 (font-registry fontobj) 567 (font-registry fontobj)
544 (font-encoding fontobj))) 568 (font-encoding fontobj)))
545 (not (font-bold-p fontobj)) 569 (not (font-bold-p fontobj))
546 (not (font-italic-p fontobj))) 570 (not (font-italic-p fontobj))
571 (not (font-oblique-p fontobj)))
547 (face-font 'default) 572 (face-font 'default)
548 (or device (setq device (selected-device))) 573 (or device (setq device (selected-device)))
549 (let ((family (or (font-family fontobj) 574 (let ((family (or (font-family fontobj)
550 (font-default-family-for-device device) 575 (font-default-family-for-device device)
551 (x-font-families-for-device device))) 576 (x-font-families-for-device device)))
582 (let ((x (length cur-family))) 607 (let ((x (length cur-family)))
583 (while (> x 0) 608 (while (> x 0)
584 (if (= ?- (aref cur-family (1- x))) 609 (if (= ?- (aref cur-family (1- x)))
585 (aset cur-family (1- x) ? )) 610 (aset cur-family (1- x) ? ))
586 (setq x (1- x)))) 611 (setq x (1- x))))
587 (setq font-name (format "-*-%s-%s-%s-*-*-%s-*-*-*-*-*-%s-%s" 612 ;; We treat oblique and italic as equivalent. Don't ask.
588 cur-family weight 613 (let ((slants '("o" "i")))
589 (if (font-italic-p fontobj) 614 (while (and slants (not done))
590 "i" 615 (setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s"
591 "r") 616 cur-family weight
592 (if size (int-to-string size) "*") 617 (if (or (font-italic-p fontobj)
593 registry 618 (font-oblique-p fontobj))
594 encoding 619 (car slants)
595 ) 620 "r")
596 done (try-font-name font-name device)))) 621 (if size
622 (int-to-string (* 10 size)) "*")
623 registry
624 encoding
625 )
626 slants (cdr slants)
627 done (try-font-name font-name device))))))
597 (if done font-name))))) 628 (if done font-name)))))
598 629
599 630
600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 631 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601 ;;; The window-system dependent code (NS-style) 632 ;;; The window-system dependent code (NS-style)
602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 633 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
603 (defun ns-font-families-for-device (&optional device no-resetp) 634 (defun ns-font-families-for-device (&optional device no-resetp)
604 ;; For right now, assume we are going to have the same storage for 635 ;; For right now, assume we are going to have the same storage for
605 ;; device fonts for NS as we do for X. Is this a valid assumption? 636 ;; device fonts for NS as we do for X. Is this a valid assumption?
606 (or device (setq device (selected-device))) 637 (or device (setq device (selected-device)))
607 (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) 638 (if (boundp 'device-fonts-cache)
608 (if (and (not menu) (not no-resetp)) 639 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
609 (progn 640 (if (and (not menu) (not no-resetp))
610 (reset-device-font-menus device) 641 (progn
611 (ns-font-families-for-device device t)) 642 (reset-device-font-menus device)
612 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) 643 (ns-font-families-for-device device t))
613 (aref menu 0))) 644 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0))))
614 (normal (mapcar (function (lambda (x) (if x (aref x 0)))) 645 (aref menu 0)))
615 (aref menu 1)))) 646 (normal (mapcar (function (lambda (x) (if x (aref x 0))))
616 (sort (unique (nconc scaled normal)) 'string-lessp))))) 647 (aref menu 1))))
648 (sort (unique (nconc scaled normal)) 'string-lessp))))))
617 649
618 (defun ns-font-create-name (fontobj &optional device) 650 (defun ns-font-create-name (fontobj &optional device)
619 (let ((family (or (font-family fontobj) 651 (let ((family (or (font-family fontobj)
620 (ns-font-families-for-device device))) 652 (ns-font-families-for-device device)))
621 (weight (or (font-weight fontobj) :medium)) 653 (weight (or (font-weight fontobj) :medium))
624 (registry (or (font-registry fontobj) "*")) 656 (registry (or (font-registry fontobj) "*"))
625 (encoding (or (font-encoding fontobj) "*"))) 657 (encoding (or (font-encoding fontobj) "*")))
626 ;; Create a font, wow! 658 ;; Create a font, wow!
627 (if (stringp family) 659 (if (stringp family)
628 (setq family (list family))) 660 (setq family (list family)))
629 (if (symbolp style) 661 (if (or (symbolp style) (numberp style))
630 (setq style (list style))) 662 (setq style (list style)))
631 (setq weight (font-higher-weight weight (car-safe (memq :bold style)))) 663 (setq weight (font-higher-weight weight (car-safe (memq :bold style))))
632 (if (stringp size) 664 (if (stringp size)
633 (setq size (font-spatial-to-canonical size device))) 665 (setq size (font-spatial-to-canonical size device)))
634 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings)) 666 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings))
651 ;; CARL: Need help here - I am not familiar with the NS font 683 ;; CARL: Need help here - I am not familiar with the NS font
652 ;; model 684 ;; model
653 (setq font-name "UNKNOWN FORMULA GOES HERE" 685 (setq font-name "UNKNOWN FORMULA GOES HERE"
654 done (try-font-name font-name device)))) 686 done (try-font-name font-name device))))
655 (if done font-name)))) 687 (if done font-name))))
688
689
690 ;;; Cache building code
691 (defun x-font-build-cache (&optional device)
692 (let ((hashtable (make-hash-table :test 'equal :size 15))
693 (fonts (mapcar 'x-font-create-object
694 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
695 (plist nil)
696 (cur nil))
697 (while fonts
698 (setq cur (car fonts)
699 fonts (cdr fonts)
700 plist (cl-gethash (car (font-family cur)) hashtable))
701 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
702 (setq plist (plist-put plist 'weights (cons (font-weight cur)
703 (plist-get plist 'weights)))))
704 (if (not (member (font-size cur) (plist-get plist 'sizes)))
705 (setq plist (plist-put plist 'sizes (cons (font-size cur)
706 (plist-get plist 'sizes)))))
707 (if (and (font-oblique-p cur)
708 (not (memq 'oblique (plist-get plist 'styles))))
709 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
710 (if (and (font-italic-p cur)
711 (not (memq 'italic (plist-get plist 'styles))))
712 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
713 (cl-puthash (car (font-family cur)) plist hashtable))
714 hashtable))
656 715
657 716
658 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 717 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
659 ;;; Now overwrite the original copy of set-face-font with our own copy that 718 ;;; Now overwrite the original copy of set-face-font with our own copy that
660 ;;; can deal with either syntax. 719 ;;; can deal with either syntax.
920 into their components. 979 into their components.
921 RGB values for color names are looked up in the rgb.txt file. 980 RGB values for color names are looked up in the rgb.txt file.
922 The variable x-library-search-path is use to locate the rgb.txt file." 981 The variable x-library-search-path is use to locate the rgb.txt file."
923 (let ((case-fold-search t)) 982 (let ((case-fold-search t))
924 (cond 983 (cond
925 ((font-rgb-color-p color) 984 ((and (font-rgb-color-p color) (floatp (aref color 1)))
926 (list (* 65535 (font-rgb-color-red color))
927 (* 65535 (font-rgb-color-green color))
928 (* 65535 (font-rgb-color-blue color))))
929 ((and (vectorp color) (= 3 (length color)) (floatp (aref color 0)))
930 (list (* 65535 (aref color 0)) 985 (list (* 65535 (aref color 0))
931 (* 65535 (aref color 1)) 986 (* 65535 (aref color 1))
932 (* 65535 (aref color 2)))) 987 (* 65535 (aref color 2))))
988 ((font-rgb-color-p color)
989 (list (font-rgb-color-red color)
990 (font-rgb-color-green color)
991 (font-rgb-color-blue color)))
933 ((and (vectorp color) (= 3 (length color))) 992 ((and (vectorp color) (= 3 (length color)))
934 (list (aref color 0) (aref color 1) (aref color 2))) 993 (list (aref color 0) (aref color 1) (aref color 2)))
935 ((and (listp color) (= 3 (length color)) (floatp (car color))) 994 ((and (listp color) (= 3 (length color)) (floatp (car color)))
936 (mapcar (function (lambda (x) (* x 65535))) color)) 995 (mapcar (function (lambda (x) (* x 65535))) color))
937 ((and (listp color) (= 3 (length color))) 996 ((and (listp color) (= 3 (length color)))
999 (defun font-normalize-color (color &optional device) 1058 (defun font-normalize-color (color &optional device)
1000 "Return an RGB tuple, given any form of input. If an error occurs, black 1059 "Return an RGB tuple, given any form of input. If an error occurs, black
1001 is returned." 1060 is returned."
1002 (cond 1061 (cond
1003 ((eq (device-type device) 'x) 1062 ((eq (device-type device) 'x)
1004 (apply 'format "#%04x%04x%04x" (font-color-rgb-components color))) 1063 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
1005 ((eq (device-type device) 'tty) 1064 ((eq (device-type device) 'tty)
1006 (apply 'font-tty-find-closest-color (font-color-rgb-components color))) 1065 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
1007 ((eq (device-type device) 'ns) 1066 ((eq (device-type device) 'ns)
1008 (let ((vals (mapcar (function (lambda (x) (>> x 8))) 1067 (let ((vals (mapcar (function (lambda (x) (>> x 8)))
1009 (font-color-rgb-components color)))) 1068 (font-color-rgb-components color))))
1010 (apply 'format "RGB%02x%02x%02ff" vals))) 1069 (apply 'format "RGB%02x%02x%02xff" vals)))
1011 (t "black"))) 1070 (t "black")))
1012 1071
1013 (defun font-set-face-background (&optional face color &rest args) 1072 (defun font-set-face-background (&optional face color &rest args)
1014 (interactive) 1073 (interactive)
1015 (if (interactive-p) 1074 (if (interactive-p)