Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; font.el,v --- New font model
2 ;; Author: wmperry
3 ;; Created: 1996/05/29 15:44:56
4 ;; Version: 1.45
5 ;; Keywords: faces
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
11 ;;;
12 ;;; 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 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version.
16 ;;;
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; The emacsen compatibility package - load it up before anything else
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (eval-and-compile
31 (load-library "w3-sysdp"))
32
33 (if (not (fboundp '<<)) (fset '<< 'lsh))
34 (if (not (fboundp '&)) (fset '& 'logand))
35 (if (not (fboundp '|)) (fset '| 'logior))
36 (if (not (fboundp '~)) (fset '~ 'lognot))
37 (if (not (fboundp '>>)) (defun >> (value count) (<< value (- count))))
38
39
40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41 ;;; Lots of variables / keywords for use later in the program
42 ;;; Not much should need to be modified
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
44 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
45 "Whether we are running in XEmacs or not.")
46
47 (defmacro defkeyword (keyword &optional docstring)
48 (list 'defconst keyword (list 'quote keyword)
49 (or docstring "A keyword")))
50
51 (defconst font-window-system-mappings
52 '((x . (x-font-create-name x-font-create-object))
53 (ns . (ns-font-create-name ns-font-create-object))
54 (tty . (tty-font-create-plist tty-font-create-object)))
55 "An assoc list mapping device types to the function used to create
56 a font name from a font structure.")
57
58 (defconst ns-font-weight-mappings
59 '((:extra-light . "extralight")
60 (:light . "light")
61 (:demi-light . "demilight")
62 (:medium . "medium")
63 (:normal . "normal")
64 (:demi-bold . "demibold")
65 (:bold . "bold")
66 (:extra-bold . "extrabold"))
67 "An assoc list mapping keywords to actual NeXTstep specific
68 information to use")
69
70 (defconst x-font-weight-mappings
71 '((:extra-light . "extralight")
72 (:light . "light")
73 (:demi-light . "demilight")
74 (:demi . "demi")
75 (:book . "book")
76 (:medium . "medium")
77 (:normal . "normal")
78 (:demi-bold . "demibold")
79 (:bold . "bold")
80 (:extra-bold . "extrabold"))
81 "An assoc list mapping keywords to actual Xwindow specific strings
82 for use in the 'weight' field of an X font string.")
83
84 (defconst font-possible-weights
85 (mapcar 'car x-font-weight-mappings))
86
87 (defvar font-rgb-file nil
88 "Where the RGB file was found.")
89
90 (defvar font-maximum-slippage "1pt"
91 "How much a font is allowed to vary from the desired size.")
92
93 (defvar font-family-mappings
94 '(
95 ("serif" . ("garamond"
96 "palatino"
97 "times new roman"
98 "baskerville"
99 "bookman"
100 "bodoni"
101 "computer modern"
102 "rockwell"
103 ))
104 ("sans-serif" . ("lucida"
105 "lucidatypewriter"
106 "gills-sans"
107 "avant-garde"
108 "univers"
109 "helvetica"
110 "optima"))
111 ("elfin" . ("tymes"))
112 ("monospace" . ("courier" "lucidatypewriter" "fixed"))
113 ("cursive" . ("sirene" "zapf chancery"))
114 )
115 "A list of font family mappings.")
116
117 (defkeyword :family "Keyword specifying the font family of a FONTOBJ.")
118
119 (defkeyword :weight "Keyword specifying the font weight of a FONTOBJ.")
120 (defkeyword :extra-light)
121 (defkeyword :light)
122 (defkeyword :demi-light)
123 (defkeyword :medium)
124 (defkeyword :normal)
125 (defkeyword :demi-bold)
126 (defkeyword :bold)
127 (defkeyword :extra-bold)
128
129 (defkeyword :style "Keyword specifying the font style of a FONTOBJ.")
130 (defkeyword :size "Keyword specifying the font size of a FONTOBJ.")
131 (defkeyword :registry "Keyword specifying the registry of a FONTOBJ.")
132 (defkeyword :encoding "Keyword specifying the encoding of a FONTOBJ.")
133
134 (eval-when-compile
135 (defmacro define-new-mask (attr mask)
136 (`
137 (progn
138 (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask))
139 (, (format
140 "Bitmask for whether a font is to be rendered in %s or not."
141 attr)))
142 (defun (, (intern (format "font-%s-p" attr))) (fontobj)
143 (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr))
144 (if (/= 0 (& (font-style fontobj)
145 (, (intern (format "font-%s-mask" attr)))))
146 t
147 nil))
148 (defun (, (intern (format "font-set-%s-p" attr))) (fontobj val)
149 (, (format "Set whether FONTOBJ will be renderd in `%s' or not."
150 attr))
151 (if val
152 (set-font-style fontobj (| (font-style fontobj)
153 (, (intern
154 (format "font-%s-mask" attr)))))
155 (set-font-style fontobj (logxor (font-style fontobj)
156 (, (intern
157 (format "font-%s-mask"
158 attr)))))))
159 ))))
160
161 (let ((mask 0))
162 (define-new-mask bold (setq mask (1+ mask)))
163 (define-new-mask italic (setq mask (1+ mask)))
164 (define-new-mask oblique (setq mask (1+ mask)))
165 (define-new-mask dim (setq mask (1+ mask)))
166 (define-new-mask underline (setq mask (1+ mask)))
167 (define-new-mask overline (setq mask (1+ mask)))
168 (define-new-mask linethrough (setq mask (1+ mask)))
169 (define-new-mask strikethru (setq mask (1+ mask)))
170 (define-new-mask reverse (setq mask (1+ mask)))
171 (define-new-mask blink (setq mask (1+ mask)))
172 (define-new-mask smallcaps (setq mask (1+ mask)))
173 (define-new-mask bigcaps (setq mask (1+ mask)))
174 (define-new-mask dropcaps (setq mask (1+ mask))))
175
176 (defvar font-caps-display-table
177 (let ((table (make-display-table))
178 (i 0))
179 ;; Standard ASCII characters
180 (while (< i 26)
181 (aset table (+ i ?a) (+ i ?A))
182 (setq i (1+ i)))
183 ;; Now ISO translations
184 (setq i 224)
185 (while (< i 247) ;; Agrave - Ouml
186 (aset table i (- i 32))
187 (setq i (1+ i)))
188 (setq i 248)
189 (while (< i 255) ;; Oslash - Thorn
190 (aset table i (- i 32))
191 (setq i (1+ i)))
192 table))
193
194 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
195 ;;; Utility functions
196 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
197 (defun unique (list)
198 (let ((retval)
199 (cur))
200 (while list
201 (setq cur (car list)
202 list (cdr list))
203 (if (member cur retval)
204 nil
205 (setq retval (cons cur retval))))
206 (nreverse retval)))
207
208 (defun font-higher-weight (w1 w2)
209 (let ((index1 (length (memq w1 font-possible-weights)))
210 (index2 (length (memq w2 font-possible-weights))))
211 (cond
212 ((<= index1 index2)
213 (or w1 w2))
214 ((not w2)
215 w1)
216 (t
217 w2))))
218
219 (defun font-spatial-to-canonical (spec &optional device)
220 "Convert SPEC (in inches, millimeters, points, or picas) into pixels"
221 ;; 1 in = 25.4 mm = 72 pt = 6 pa
222 (if (numberp spec)
223 spec
224 (let ((num nil)
225 (type nil)
226 ;; If for any reason we get null for any of this, default
227 ;; to 1024x768 resolution on a 17" screen
228 (pix-width (float (or (device-pixel-width device) 1024)))
229 (mm-width (float (or (device-mm-width device) 293)))
230 (retval nil))
231 (if (string-match "[^0-9.]+$" spec)
232 (setq type (substring spec (match-beginning 0))
233 spec (substring spec 0 (match-beginning 0)))
234 (setq type "px"
235 spec spec))
236 (setq num (string-to-number spec))
237 (cond
238 ((member type '("pixel" "px" "pix"))
239 (setq retval num
240 num nil))
241 ((member type '("point" "pt"))
242 (setq retval (+ (* (/ pix-width mm-width)
243 (/ 25.4 72.0)
244 num))))
245 ((member type '("pica" "pa"))
246 (setq retval (* (/ pix-width mm-width)
247 (/ 25.4 6.0)
248 num)))
249 ((member type '("inch" "in"))
250 (setq retval (* (/ pix-width mm-width)
251 (/ 25.4 1.0)
252 num)))
253 ((string= type "mm")
254 (setq retval (* (/ pix-width mm-width)
255 num)))
256 ((string= type "cm")
257 (setq retval (* (/ pix-width mm-width)
258 10
259 num)))
260 (t (setq retval num))
261 )
262 retval)))
263
264
265 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
266 ;;; The main interface routines - constructors and accessor functions
267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
268 (defun make-font (&rest args)
269 (vector :family
270 (if (stringp (nth 1 (memq :family args)))
271 (list (nth 1 (memq :family args)))
272 (nth 1 (memq :family args)))
273 :weight
274 (nth 1 (memq :weight args))
275 :style
276 (if (numberp (nth 1 (memq :style args)))
277 (nth 1 (memq :style args))
278 0)
279 :size
280 (nth 1 (memq :size args))
281 :registry
282 (nth 1 (memq :registry args))
283 :encoding
284 (nth 1 (memq :encoding args))))
285
286 (defsubst set-font-family (fontobj family)
287 (aset fontobj 1 family))
288
289 (defsubst set-font-weight (fontobj weight)
290 (aset fontobj 3 weight))
291
292 (defsubst set-font-style (fontobj style)
293 (aset fontobj 5 style))
294
295 (defsubst set-font-size (fontobj size)
296 (aset fontobj 7 size))
297
298 (defsubst set-font-registry (fontobj reg)
299 (aset fontobj 9 reg))
300
301 (defsubst set-font-encoding (fontobj enc)
302 (aset fontobj 11 enc))
303
304 (defsubst font-family (fontobj)
305 (aref fontobj 1))
306
307 (defsubst font-weight (fontobj)
308 (aref fontobj 3))
309
310 (defsubst font-style (fontobj)
311 (aref fontobj 5))
312
313 (defsubst font-size (fontobj)
314 (aref fontobj 7))
315
316 (defsubst font-registry (fontobj)
317 (aref fontobj 9))
318
319 (defsubst font-encoding (fontobj)
320 (aref fontobj 11))
321
322 (defun font-create-name (fontobj &optional device)
323 (let* ((type (device-type device))
324 (func (car (cdr-safe (assq type font-window-system-mappings)))))
325 (and func (fboundp func) (funcall func fontobj device))))
326
327 (defun font-create-object (fontname &optional device)
328 (let* ((type (device-type device))
329 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
330 (and func (fboundp func) (funcall func fontname device))))
331
332 (defun font-combine-fonts-internal (fontobj-1 fontobj-2)
333 (let ((retval (make-font))
334 (size-1 (and (font-size fontobj-1)
335 (font-spatial-to-canonical (font-size fontobj-1))))
336 (size-2 (and (font-size fontobj-2)
337 (font-spatial-to-canonical (font-size fontobj-2)))))
338 (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
339 (font-weight fontobj-2)))
340 (set-font-family retval (unique (append (font-family fontobj-1)
341 (font-family fontobj-2))))
342 (set-font-style retval (| (font-style fontobj-1) (font-style fontobj-2)))
343 (set-font-registry retval (or (font-registry fontobj-1)
344 (font-registry fontobj-2)))
345 (set-font-encoding retval (or (font-encoding fontobj-1)
346 (font-encoding fontobj-2)))
347 (set-font-size retval (cond
348 ((and size-1 size-2 (>= size-2 size-1))
349 (font-size fontobj-2))
350 ((and size-1 size-2)
351 (font-size fontobj-1))
352 (size-1
353 (font-size fontobj-1))
354 (size-2
355 (font-size fontobj-2))
356 (t nil)))
357
358 retval))
359
360 (defun font-combine-fonts (&rest args)
361 (cond
362 ((null args)
363 (error "Wrong number of arguments to font-combine-fonts"))
364 ((= (length args) 1)
365 (car args))
366 (t
367 (let ((retval (font-combine-fonts-internal (nth 0 args) (nth 1 args))))
368 (setq args (cdr (cdr args)))
369 (while args
370 (setq retval (font-combine-fonts-internal retval (car args))
371 args (cdr args)))
372 retval))))
373
374
375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
376 ;;; The window-system dependent code (TTY-style)
377 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
378 (defun tty-font-create-object (fontname &optional device)
379 )
380
381 (defun tty-font-create-plist (fontobj &optional device)
382 (let ((styles (font-style fontobj))
383 (weight (font-weight fontobj)))
384 (list
385 (cons 'underline (font-underline-p fontobj))
386 (cons 'highlight (if (or (font-bold-p fontobj)
387 (memq weight '(:bold :demi-bold))) t))
388 (cons 'dim (font-dim-p fontobj))
389 (cons 'blinking (font-blink-p fontobj))
390 (cons 'reverse (font-reverse-p fontobj)))))
391
392
393 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
394 ;;; The window-system dependent code (X-style)
395 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
396 (defvar font-x-font-regexp (or (and font-running-xemacs
397 (boundp 'x-font-regexp)
398 x-font-regexp)
399 (let
400 ((- "[-?]")
401 (foundry "[^-]*")
402 (family "[^-]*")
403 (weight "\\(bold\\|demibold\\|medium\\|black\\)")
404 (weight\? "\\([^-]*\\)")
405 (slant "\\([ior]\\)")
406 (slant\? "\\([^-]?\\)")
407 (swidth "\\([^-]*\\)")
408 (adstyle "\\([^-]*\\)")
409 (pixelsize "\\(\\*\\|[0-9]+\\)")
410 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)")
411 (resx "\\([*0]\\|[0-9][0-9]+\\)")
412 (resy "\\([*0]\\|[0-9][0-9]+\\)")
413 (spacing "[cmp?*]")
414 (avgwidth "\\(\\*\\|[0-9]+\\)")
415 (registry "[^-]*")
416 (encoding "[^-]+")
417 )
418 (concat "\\`\\*?[-?*]"
419 foundry - family - weight\? - slant\? - swidth - adstyle -
420 pixelsize - pointsize - resx - resy - spacing - avgwidth -
421 registry - encoding "\\'"
422 ))))
423
424 (defun x-font-create-object (fontname &optional device)
425 (if (or (not (stringp fontname))
426 (not (string-match font-x-font-regexp fontname)))
427 (make-font)
428 (let ((family nil)
429 (style nil)
430 (size nil)
431 (weight (match-string 1 fontname))
432 (slant (match-string 2 fontname))
433 (swidth (match-string 3 fontname))
434 (adstyle (match-string 4 fontname))
435 (pxsize (match-string 5 fontname))
436 (ptsize (match-string 6 fontname))
437 (retval nil)
438 (case-fold-search t)
439 )
440 (if (not (string-match x-font-regexp-foundry-and-family fontname))
441 nil
442 (setq family (list (match-string 1 fontname))))
443 (if (string= "*" weight) (setq weight nil))
444 (if (string= "*" slant) (setq slant nil))
445 (if (string= "*" swidth) (setq swidth nil))
446 (if (string= "*" adstyle) (setq adstyle nil))
447 (if (string= "*" pxsize) (setq pxsize nil))
448 (if (string= "*" ptsize) (setq ptsize nil))
449 (if ptsize (setq size (format "%dpt" (/ (string-to-int ptsize) 10))))
450 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
451 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
452 (if (and adstyle (not (equal adstyle "")))
453 (setq family (append family (list adstyle))))
454 (setq retval (make-font :family family
455 :weight weight
456 :size size))
457 (font-set-bold-p retval (eq :bold weight))
458 (cond
459 ((null slant) nil)
460 ((member slant '("i" "I"))
461 (font-set-italic-p retval t))
462 ((member slant '("o" "O"))
463 (font-set-oblique-p retval t)))
464 retval)))
465
466 (defun x-font-families-for-device (&optional device no-resetp)
467 (condition-case ()
468 (require 'x-font-menu)
469 (error nil))
470 (or device (setq device (selected-device)))
471 (if (boundp 'device-fonts-cache)
472 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
473 (if (and (not menu) (not no-resetp))
474 (progn
475 (reset-device-font-menus device)
476 (x-font-families-for-device device t))
477 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0))))
478 (aref menu 0)))
479 (normal (mapcar (function (lambda (x) (if x (aref x 0))))
480 (aref menu 1))))
481 (sort (unique (nconc scaled normal)) 'string-lessp))))
482 (mapcar 'car font-family-mappings)))
483
484 (defvar font-default-cache nil)
485
486 (defun font-default-font-for-device (&optional device)
487 (or device (setq device (selected-device)))
488 (if font-running-xemacs
489 (face-font-name 'default device)
490 (cdr-safe (assq 'font (frame-parameters device)))))
491
492 (defun font-default-object-for-device (&optional device)
493 (let ((font (font-default-font-for-device device)))
494 (or (cdr-safe
495 (assoc font font-default-cache))
496 (progn
497 (setq font-default-cache (cons (cons font
498 (font-create-object font))
499 font-default-cache))
500 (cdr-safe (assoc font font-default-cache))))))
501
502 (defun font-default-family-for-device (&optional device)
503 (or device (setq device (selected-device)))
504 (font-family (font-default-object-for-device device)))
505
506 (defun font-default-size-for-device (&optional device)
507 (or device (setq device (selected-device)))
508 (if font-running-xemacs
509 (format "%dpx" (face-height 'default device))
510 (font-size (font-default-object-for-device device))))
511
512 (defun x-font-create-name (fontobj &optional device)
513 (if (and (not (or (font-family fontobj)
514 (font-weight fontobj)
515 (font-size fontobj)
516 (font-registry fontobj)
517 (font-encoding fontobj)))
518 (not (font-bold-p fontobj))
519 (not (font-italic-p fontobj)))
520 (face-font 'default)
521 (or device (setq device (selected-device)))
522 (let ((family (or (font-family fontobj)
523 (font-default-family-for-device device)
524 (x-font-families-for-device device)))
525 (weight (or (font-weight fontobj) :medium))
526 (style (font-style fontobj))
527 (size (or (font-size fontobj) (font-default-size-for-device device)))
528 (registry (or (font-registry fontobj) "*"))
529 (encoding (or (font-encoding fontobj) "*")))
530 (if (stringp family)
531 (setq family (list family)))
532 (setq weight (font-higher-weight weight
533 (and (font-bold-p fontobj) :bold)))
534 (if (stringp size)
535 (setq size (round (font-spatial-to-canonical size device))))
536 (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*"))
537 (let ((done nil) ; Did we find a good font yet?
538 (font-name nil) ; font name we are currently checking
539 (cur-family nil) ; current family we are checking
540 )
541 (while (and family (not done))
542 (setq cur-family (car family)
543 family (cdr family))
544 (if (assoc cur-family font-family-mappings)
545 ;; If the family name is an alias as defined by
546 ;; font-family-mappings, then append those families
547 ;; to the front of 'family' and continue in the loop.
548 (setq family (append
549 (cdr-safe (assoc cur-family
550 font-family-mappings))
551 family))
552 ;; Not an alias for a list of fonts, so we just check it.
553 ;; First, convert all '-' to spaces so that we don't screw up
554 ;; the oh-so wonderful X font model. Wheee.
555 (let ((x (length cur-family)))
556 (while (> x 0)
557 (if (= ?- (aref cur-family (1- x)))
558 (aset cur-family (1- x) ? ))
559 (setq x (1- x))))
560 (setq font-name (format "-*-%s-%s-%s-*-*-%s-*-*-*-*-*-%s-%s"
561 cur-family weight
562 (if (font-italic-p fontobj)
563 "i"
564 "r")
565 (if size (int-to-string size) "*")
566 registry
567 encoding
568 )
569 done (try-font-name font-name device))))
570 (if done font-name)))))
571
572
573 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
574 ;;; The window-system dependent code (NS-style)
575 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
576 (defun ns-font-families-for-device (&optional device no-resetp)
577 ;; For right now, assume we are going to have the same storage for
578 ;; device fonts for NS as we do for X. Is this a valid assumption?
579 (or device (setq device (selected-device)))
580 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
581 (if (and (not menu) (not no-resetp))
582 (progn
583 (reset-device-font-menus device)
584 (ns-font-families-for-device device t))
585 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0))))
586 (aref menu 0)))
587 (normal (mapcar (function (lambda (x) (if x (aref x 0))))
588 (aref menu 1))))
589 (sort (unique (nconc scaled normal)) 'string-lessp)))))
590
591 (defun ns-font-create-name (fontobj &optional device)
592 (let ((family (or (font-family fontobj)
593 (ns-font-families-for-device device)))
594 (weight (or (font-weight fontobj) :medium))
595 (style (or (font-style fontobj) (list :normal)))
596 (size (font-size fontobj))
597 (registry (or (font-registry fontobj) "*"))
598 (encoding (or (font-encoding fontobj) "*")))
599 ;; Create a font, wow!
600 (if (stringp family)
601 (setq family (list family)))
602 (if (symbolp style)
603 (setq style (list style)))
604 (setq weight (font-higher-weight weight (car-safe (memq :bold style))))
605 (if (stringp size)
606 (setq size (font-spatial-to-canonical size device)))
607 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings))
608 "medium"))
609 (let ((done nil) ; Did we find a good font yet?
610 (font-name nil) ; font name we are currently checking
611 (cur-family nil) ; current family we are checking
612 )
613 (while (and family (not done))
614 (setq cur-family (car family)
615 family (cdr family))
616 (if (assoc cur-family font-family-mappings)
617 ;; If the family name is an alias as defined by
618 ;; font-family-mappings, then append those families
619 ;; to the front of 'family' and continue in the loop.
620 (setq family (append
621 (cdr-safe (assoc cur-family
622 font-family-mappings))
623 family))
624 ;; CARL: Need help here - I am not familiar with the NS font
625 ;; model
626 (setq font-name "UNKNOWN FORMULA GOES HERE"
627 done (try-font-name font-name device))))
628 (if done font-name))))
629
630
631 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
632 ;;; Now overwrite the original copy of set-face-font with our own copy that
633 ;;; can deal with either syntax.
634 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
635 (defun font-set-face-font (&optional face font &rest args)
636 (if (interactive-p)
637 (call-interactively 'font-original-set-face-font)
638 (cond
639 ((and (vectorp font) (= (length font) 12))
640 (let ((font-name (font-create-name font)))
641 (set-face-property face 'font-specification font)
642 (cond
643 ((null font-name) ; No matching font!
644 nil)
645 ((listp font-name) ; For TTYs
646 (let (cur)
647 (while font-name
648 (setq cur (car font-name)
649 font-name (cdr font-name))
650 (apply 'set-face-property face (car cur) (cdr cur) args))))
651 (font-running-xemacs
652 (apply 'font-original-set-face-font face font-name args)
653 (apply 'set-face-underline-p face (font-underline-p font) args)
654 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
655 (fboundp 'set-face-display-table))
656 (apply 'set-face-display-table
657 face font-caps-display-table args))
658 (apply 'set-face-property face 'strikethru (or
659 (font-linethrough-p font)
660 (font-strikethru-p font))
661 args))
662 (t
663 (condition-case nil
664 (apply 'font-original-set-face-font face font-name args)
665 (error
666 (let ((args (car-safe args)))
667 (and (or (font-bold-p font)
668 (memq (font-weight font) '(:bold :demi-bold)))
669 (make-face-bold face args t))
670 (and (font-italic-p font) (make-face-italic face args t)))))
671 (apply 'set-face-underline-p face (font-underline-p font) args)))))
672 (t
673 ;; Let the original set-face-font signal any errors
674 (set-face-property face 'font-specification nil)
675 (apply 'font-original-set-face-font face font args)))))
676
677
678 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
679 ;;; Now for emacsen specific stuff
680 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
681 (defun font-update-device-fonts (device)
682 ;; Update all faces that were created with the 'font' package
683 ;; to appear correctly on the new device. This should be in the
684 ;; create-device-hook. This is XEmacs 19.12+ specific
685 (let ((faces (face-list 2))
686 (cur nil)
687 (font nil)
688 (font-spec nil))
689 (while faces
690 (setq cur (car faces)
691 faces (cdr faces)
692 font-spec (face-property cur 'font-specification))
693 (if font-spec
694 (set-face-font cur font-spec device)))))
695
696 (defun font-update-one-face (face &optional device-list)
697 ;; Update FACE on all devices in DEVICE-LIST
698 ;; DEVICE_LIST defaults to a list of all active devices
699 (setq device-list (or device-list (device-list)))
700 (if (devicep device-list)
701 (setq device-list (list device-list)))
702 (let* ((cur-device nil)
703 (font-spec (face-property face 'font-specification))
704 (font nil))
705 (if (not font-spec)
706 ;; Hey! Don't mess with fonts we didn't create in the
707 ;; first place.
708 nil
709 (while device-list
710 (setq cur-device (car device-list)
711 device-list (cdr device-list))
712 (if (not (device-live-p cur-device))
713 ;; Whoah!
714 nil
715 (if font-spec
716 (set-face-font face font-spec cur-device)))))))
717
718 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
719 ;;; Various color related things
720 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
721 (cond
722 ((fboundp 'display-warning)
723 (fset 'font-warn 'display-warning))
724 ((fboundp 'w3-warn)
725 (fset 'font-warn 'w3-warn))
726 ((fboundp 'url-warn)
727 (fset 'font-warn 'url-warn))
728 ((fboundp 'warn)
729 (defun font-warn (class message &optional level)
730 (warn "(%s/%s) %s" class (or level 'warning) message)))
731 (t
732 (defun font-warn (class message &optional level)
733 (save-excursion
734 (set-buffer (get-buffer-create "*W3-WARNINGS*"))
735 (goto-char (point-max))
736 (save-excursion
737 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
738 (display-buffer (current-buffer))))))
739
740 (defun font-lookup-rgb-components (color)
741 "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
742 The list (R G B) is returned, or an error is signaled if the lookup fails."
743 (let ((lib-list (if (boundp 'x-library-search-path)
744 x-library-search-path
745 ;; This default is from XEmacs 19.13 - hope it covers
746 ;; everyone.
747 (list "/usr/X11R6/lib/X11/"
748 "/usr/X11R5/lib/X11/"
749 "/usr/lib/X11R6/X11/"
750 "/usr/lib/X11R5/X11/"
751 "/usr/local/X11R6/lib/X11/"
752 "/usr/local/X11R5/lib/X11/"
753 "/usr/local/lib/X11R6/X11/"
754 "/usr/local/lib/X11R5/X11/"
755 "/usr/X11/lib/X11/"
756 "/usr/lib/X11/"
757 "/usr/local/lib/X11/"
758 "/usr/X386/lib/X11/"
759 "/usr/x386/lib/X11/"
760 "/usr/XFree86/lib/X11/"
761 "/usr/unsupported/lib/X11/"
762 "/usr/athena/lib/X11/"
763 "/usr/local/x11r5/lib/X11/"
764 "/usr/lpp/Xamples/lib/X11/"
765 "/usr/openwin/lib/X11/"
766 "/usr/openwin/share/lib/X11/")))
767 (file font-rgb-file)
768 r g b)
769 (if (not file)
770 (while lib-list
771 (setq file (expand-file-name "rgb.txt" (car lib-list)))
772 (if (file-readable-p file)
773 (setq lib-list nil
774 font-rgb-file file)
775 (setq lib-list (cdr lib-list)
776 file nil))))
777 (if (null file)
778 (list 0 0 0)
779 (save-excursion
780 (set-buffer (find-file-noselect file))
781 (if (not (= (aref (buffer-name) 0) ? ))
782 (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*")))
783 (save-excursion
784 (save-restriction
785 (widen)
786 (goto-char (point-min))
787 (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t)
788 (progn
789 (beginning-of-line)
790 (setq r (* (read (current-buffer)) 256)
791 g (* (read (current-buffer)) 256)
792 b (* (read (current-buffer)) 256)))
793 (font-warn 'color (format "No such color: %s" color))
794 (setq r 0
795 g 0
796 b 0))
797 (list r g b) ))))))
798
799 (defun font-hex-string-to-number (string)
800 "Convert STRING to an integer by parsing it as a hexadecimal number."
801 (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
802 (?1 . 1) (?b . 11) (?B . 11)
803 (?2 . 2) (?c . 12) (?C . 12)
804 (?3 . 3) (?d . 13) (?D . 13)
805 (?4 . 4) (?e . 14) (?E . 14)
806 (?5 . 5) (?f . 15) (?F . 15)
807 (?6 . 6)
808 (?7 . 7)
809 (?8 . 8)
810 (?9 . 9)))
811 (n 0)
812 (i 0)
813 (lim (length string)))
814 (while (< i lim)
815 (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0))
816 i (1+ i)))
817 n ))
818
819 (defun font-parse-rgb-components (color)
820 "Parse RGB color specification and return a list of integers (R G B).
821 #FEFEFE and rgb:fe/fe/fe style specifications are parsed."
822 (let ((case-fold-search t)
823 r g b str)
824 (cond ((string-match "^#[0-9a-f]+$" color)
825 (cond
826 ((= (length color) 4)
827 (setq r (font-hex-string-to-number (substring color 1 2))
828 g (font-hex-string-to-number (substring color 2 3))
829 b (font-hex-string-to-number (substring color 3 4))
830 r (* r 4096)
831 g (* g 4096)
832 b (* b 4096)))
833 ((= (length color) 7)
834 (setq r (font-hex-string-to-number (substring color 1 3))
835 g (font-hex-string-to-number (substring color 3 5))
836 b (font-hex-string-to-number (substring color 5 7))
837 r (* r 256)
838 g (* g 256)
839 b (* b 256)))
840 ((= (length color) 10)
841 (setq r (font-hex-string-to-number (substring color 1 4))
842 g (font-hex-string-to-number (substring color 4 7))
843 b (font-hex-string-to-number (substring color 7 10))
844 r (* r 16)
845 g (* g 16)
846 b (* b 16)))
847 ((= (length color) 13)
848 (setq r (font-hex-string-to-number (substring color 1 5))
849 g (font-hex-string-to-number (substring color 5 9))
850 b (font-hex-string-to-number (substring color 9 13))))
851 (t
852 (font-warn 'color (format "Invalid RGB color specification: %s"
853 color))
854 (setq r 0
855 g 0
856 b 0))))
857 ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
858 color)
859 (if (or (> (- (match-end 1) (match-beginning 1)) 4)
860 (> (- (match-end 2) (match-beginning 2)) 4)
861 (> (- (match-end 3) (match-beginning 3)) 4))
862 (error "Invalid RGB color specification: %s" color)
863 (setq str (match-string 1 color)
864 r (* (font-hex-string-to-number str)
865 (expt 16 (- 4 (length str))))
866 str (match-string 2 color)
867 g (* (font-hex-string-to-number str)
868 (expt 16 (- 4 (length str))))
869 str (match-string 3 color)
870 b (* (font-hex-string-to-number str)
871 (expt 16 (- 4 (length str)))))))
872 (t
873 (font-warn 'html (format "Invalid RGB color specification: %s"
874 color))
875 (setq r 0
876 g 0
877 b 0)))
878 (list r g b) ))
879
880 (defsubst font-rgb-color-p (obj)
881 (and (vectorp obj)
882 (= (length obj) 4)
883 (eq (aref obj 0) 'rgb)))
884
885 (defsubst font-rgb-color-red (obj) (aref obj 1))
886 (defsubst font-rgb-color-green (obj) (aref obj 2))
887 (defsubst font-rgb-color-blue (obj) (aref obj 3))
888
889 (defun font-color-rgb-components (color)
890 "Return the RGB components of COLOR as a list of integers (R G B).
891 16-bit values are always returned.
892 #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
893 into their components.
894 RGB values for color names are looked up in the rgb.txt file.
895 The variable x-library-search-path is use to locate the rgb.txt file."
896 (let ((case-fold-search t))
897 (cond
898 ((font-rgb-color-p color)
899 (list (* 65535 (font-rgb-color-red color))
900 (* 65535 (font-rgb-color-green color))
901 (* 65535 (font-rgb-color-blue color))))
902 ((and (vectorp color) (= 3 (length color)) (floatp (aref color 0)))
903 (list (* 65535 (aref color 0))
904 (* 65535 (aref color 1))
905 (* 65535 (aref color 2))))
906 ((and (vectorp color) (= 3 (length color)))
907 (list (aref color 0) (aref color 1) (aref color 2)))
908 ((and (listp color) (= 3 (length color)) (floatp (car color)))
909 (mapcar (function (lambda (x) (* x 65535))) color))
910 ((and (listp color) (= 3 (length color)))
911 color)
912 ((or (string-match "^#" color)
913 (string-match "^rgb:" color))
914 (font-parse-rgb-components color))
915 ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)"
916 color)
917 (let ((r (string-to-number (match-string 1 color)))
918 (g (string-to-number (match-string 2 color)))
919 (b (string-to-number (match-string 3 color))))
920 (if (floatp r)
921 (setq r (round (* 255 r))
922 g (round (* 255 g))
923 b (round (* 255 b))))
924 (font-parse-rgb-components (format "#%02x%02x%02x" r g b))))
925 (t
926 (font-lookup-rgb-components color)))))
927
928 (defsubst font-tty-compute-color-delta (col1 col2)
929 (+
930 (* (- (aref col1 0) (aref col2 0))
931 (- (aref col1 0) (aref col2 0)))
932 (* (- (aref col1 1) (aref col2 1))
933 (- (aref col1 1) (aref col2 1)))
934 (* (- (aref col1 2) (aref col2 2))
935 (- (aref col1 2) (aref col2 2)))))
936
937 (defun font-tty-find-closest-color (r g b)
938 ;; This is basically just a lisp copy of allocate_nearest_color
939 ;; from objects-x.c from Emacs 19
940 ;; We really should just check tty-color-list, but unfortunately
941 ;; that does not include any RGB information at all.
942 ;; So for now we just hardwire in the default list and call it
943 ;; good for now.
944 (setq r (/ r 65535.0)
945 g (/ g 65535.0)
946 b (/ b 65535.0))
947 (let* ((color_def (vector r g b))
948 (colors [([1.0 1.0 1.0] . "white")
949 ([0.0 1.0 1.0] . "cyan")
950 ([1.0 0.0 1.0] . "magenta")
951 ([0.0 0.0 1.0] . "blue")
952 ([1.0 1.0 0.0] . "yellow")
953 ([0.0 1.0 0.0] . "green")
954 ([1.0 0.0 0.0] . "red")
955 ([0.0 0.0 0.0] . "black")])
956 (no_cells (length colors))
957 (x 1)
958 (nearest 0)
959 (nearest_delta 0)
960 (trial_delta 0))
961 (setq nearest_delta (font-tty-compute-color-delta (car (aref colors 0))
962 color_def))
963 (while (/= no_cells x)
964 (setq trial_delta (font-tty-compute-color-delta (car (aref colors x))
965 color_def))
966 (if (< trial_delta nearest_delta)
967 (setq nearest x
968 nearest_delta trial_delta))
969 (setq x (1+ x)))
970 (cdr-safe (aref colors nearest))))
971
972 (defun font-normalize-color (color &optional device)
973 "Return an RGB tuple, given any form of input. If an error occurs, black
974 is returned."
975 (cond
976 ((eq (device-type device) 'x)
977 (apply 'format "#%04x%04x%04x" (font-color-rgb-components color)))
978 ((eq (device-type device) 'tty)
979 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
980 ((eq (device-type device) 'ns)
981 (let ((vals (mapcar (function (lambda (x) (>> x 8)))
982 (font-color-rgb-components color))))
983 (apply 'format "RGB%02x%02x%02ff" vals)))
984 (t "black")))
985
986 (defun font-set-face-background (&optional face color &rest args)
987 (interactive)
988 (if (interactive-p)
989 (call-interactively 'font-original-set-face-background)
990 (cond
991 ((font-rgb-color-p color)
992 (apply 'font-original-set-face-background face
993 (font-normalize-color color) args))
994 (t
995 (apply 'font-original-set-face-background face color args)))))
996
997 (defun font-set-face-foreground (&optional face color &rest args)
998 (interactive)
999 (if (interactive-p)
1000 (call-interactively 'font-original-set-face-foreground)
1001 (cond
1002 ((font-rgb-color-p color)
1003 (apply 'font-original-set-face-foreground face
1004 (font-normalize-color color) args))
1005 (t
1006 (apply 'font-original-set-face-foreground face color args)))))
1007
1008 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1009 ;;; Do the actual overwriting of some functions
1010 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1011 (defmacro font-overwrite-fn (func)
1012 (` (let ((our-func (intern (format "font-%s" (, func))))
1013 (new-func (intern (format "font-original-%s" (, func))))
1014 (old-func (and (fboundp (, func)) (symbol-function (, func)))))
1015 (if (not (fboundp new-func))
1016 (progn
1017 (if old-func
1018 (fset new-func old-func)
1019 (fset new-func 'ignore))
1020 (fset (, func) our-func))))))
1021
1022 (font-overwrite-fn 'set-face-foreground)
1023 (font-overwrite-fn 'set-face-background)
1024 (font-overwrite-fn 'set-face-font)
1025
1026 (provide 'font)