Mercurial > hg > xemacs-beta

comparison lisp/x-faces.el @ 3360:316fddbf58e2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2006-04-25 14:01:52 by stephent] Repair broken commit to Xft code. <87aca9n4in.fsf@tleepslib.sk.tsukuba.ac.jp>
author stephent
date Tue, 25 Apr 2006 14:02:09 +0000
parents 15fb91e3a115
children 98af8a976fc3
comparison
equal deleted inserted replaced
3359:af8dab703edc 3360:316fddbf58e2
1 ;;; x-faces.el --- X-specific face frobnication, aka black magic. 1 ;;; x-faces.el --- X-specific face frobnication, aka black magic.
2 2
3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1992-1994, 1997, 2006 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 1996, 2002, 2004 Ben Wing. 4 ;; Copyright (C) 1995, 1996, 2002, 2004 Ben Wing.
5 5
6 ;; Author: Jamie Zawinski <jwz@jwz.org> 6 ;; Author: Jamie Zawinski <jwz@jwz.org>
7 ;; Maintainer: XEmacs Development Team 7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: extensions, internal, dumped 8 ;; Keywords: extensions, internal, dumped
72 '(fc-font-name-weight-bold fc-font-name-weight-black 72 '(fc-font-name-weight-bold fc-font-name-weight-black
73 fc-font-name-weight-demibold fc-font-name-weight-medium 73 fc-font-name-weight-demibold fc-font-name-weight-medium
74 fc-font-name-slant-oblique fc-font-name-slant-italic 74 fc-font-name-slant-oblique fc-font-name-slant-italic
75 fc-font-name-slant-roman)) 75 fc-font-name-slant-roman))
76 (globally-declare-fboundp 76 (globally-declare-fboundp
77 '(fc-font-real-pattern fc-pattern-get-size fc-copy-pattern-partial 77 '(fc-pattern-del-size fc-pattern-get-size fc-pattern-add-size
78 fc-pattern-del-weight fc-pattern-del-style fc-pattern-duplicate 78 fc-pattern-del-style fc-pattern-duplicate fc-copy-pattern-partial
79 fc-pattern-add-weight fc-try-font fc-pattern-add-size 79 fc-pattern-add-weight fc-pattern-del-weight fc-try-font
80 fc-name-unparse fc-pattern-del-slant fc-pattern-add-slant 80 fc-pattern-del-slant fc-pattern-add-slant fc-name-unparse
81 fc-pattern-del-size fc-pattern-get-pixelsize))) 81 fc-pattern-get-pixelsize)))
82 82
83 (defconst x-font-regexp nil) 83 (defconst x-font-regexp nil)
84 (defconst x-font-regexp-head nil) 84 (defconst x-font-regexp-head nil)
85 (defconst x-font-regexp-head-2 nil) 85 (defconst x-font-regexp-head-2 nil)
86 (defconst x-font-regexp-weight nil) 86 (defconst x-font-regexp-weight nil)
192 (x-make-font-bold-core font device) 192 (x-make-font-bold-core font device)
193 (x-make-font-bold-xft font device)) 193 (x-make-font-bold-xft font device))
194 (x-make-font-bold-core font device))) 194 (x-make-font-bold-core font device)))
195 195
196 (defun x-make-font-bold-xft (font &optional device) 196 (defun x-make-font-bold-xft (font &optional device)
197 (let ((pattern (fc-font-real-pattern 197 (let ((pattern (fc-font-match (or device (default-x-device))
198 font (or device (default-x-device))))) 198 (fc-name-parse font))))
199 (if pattern 199 (if pattern
200 (let ((size (fc-pattern-get-size pattern 0)) 200 (let ((size (fc-pattern-get-size pattern 0))
201 (copy (fc-copy-pattern-partial pattern (list "family")))) 201 (copy (fc-copy-pattern-partial pattern (list "family"))))
202 (fc-pattern-del-weight copy) 202 (fc-pattern-del-weight copy)
203 (fc-pattern-del-style copy) 203 (fc-pattern-del-style copy)
236 (x-make-font-unbold-core font device) 236 (x-make-font-unbold-core font device)
237 (x-make-font-unbold-xft font device)) 237 (x-make-font-unbold-xft font device))
238 (x-make-font-unbold-core font device))) 238 (x-make-font-unbold-core font device)))
239 239
240 (defun x-make-font-unbold-xft (font &optional device) 240 (defun x-make-font-unbold-xft (font &optional device)
241 (let ((pattern (fc-font-real-pattern 241 (let ((pattern (fc-font-match (or device (default-x-device))
242 font (or device (default-x-device))))) 242 (fc-name-parse font))))
243 (when pattern 243 (when pattern
244 (fc-pattern-del-weight pattern) 244 (fc-pattern-del-weight pattern)
245 (fc-pattern-add-weight pattern fc-font-name-weight-medium) 245 (fc-pattern-add-weight pattern fc-font-name-weight-medium)
246 (if (fc-try-font pattern device) 246 (if (fc-try-font pattern device)
247 (fc-name-unparse pattern))))) 247 (fc-name-unparse pattern)))))
266 (x-make-font-italic-core font device) 266 (x-make-font-italic-core font device)
267 (x-make-font-italic-xft font device)) 267 (x-make-font-italic-xft font device))
268 (x-make-font-italic-core font device))) 268 (x-make-font-italic-core font device)))
269 269
270 (defun x-make-font-italic-xft (font &optional device) 270 (defun x-make-font-italic-xft (font &optional device)
271 (let ((pattern (fc-font-real-pattern 271 (let ((pattern (fc-font-match (or device (default-x-device))
272 font (or device (default-x-device))))) 272 (fc-name-parse font))))
273 (if pattern 273 (if pattern
274 (let ((size (fc-pattern-get-size pattern 0)) 274 (let ((size (fc-pattern-get-size pattern 0))
275 (copy (fc-copy-pattern-partial pattern (list "family")))) 275 (copy (fc-copy-pattern-partial pattern (list "family"))))
276 (when copy 276 (when copy
277 (fc-pattern-del-slant copy) 277 (fc-pattern-del-slant copy)
320 (x-make-font-unitalic-core font device) 320 (x-make-font-unitalic-core font device)
321 (x-make-font-unitalic-xft font device)) 321 (x-make-font-unitalic-xft font device))
322 (x-make-font-unitalic-core font device))) 322 (x-make-font-unitalic-core font device)))
323 323
324 (defun x-make-font-unitalic-xft (font &optional device) 324 (defun x-make-font-unitalic-xft (font &optional device)
325 (let ((pattern (fc-font-real-pattern 325 (let ((pattern (fc-font-match (or device (default-x-device))
326 font (or device (default-x-device))))) 326 (fc-name-parse font))))
327 (when pattern 327 (when pattern
328 (fc-pattern-del-slant pattern) 328 (fc-pattern-del-slant pattern)
329 (fc-pattern-add-slant pattern fc-font-name-slant-roman) 329 (fc-pattern-add-slant pattern fc-font-name-slant-roman)
330 (if (fc-try-font pattern device) 330 (if (fc-try-font pattern device)
331 (fc-name-unparse pattern))))) 331 (fc-name-unparse pattern)))))
387 (x-font-size-xft font)) 387 (x-font-size-xft font))
388 (x-font-size-core font))) 388 (x-font-size-core font)))
389 389
390 ;; this is unbelievable &*@# 390 ;; this is unbelievable &*@#
391 (defun x-font-size-xft (font) 391 (defun x-font-size-xft (font)
392 (let ((pattern (fc-font-real-pattern 392 (let ((pattern (fc-font-match (default-x-device)
393 font (default-x-device)))) 393 (fc-name-parse font))))
394 (when pattern 394 (when pattern
395 (let ((pixelsize (fc-pattern-get-pixelsize pattern 0))) 395 (let ((pixelsize (fc-pattern-get-pixelsize pattern 0)))
396 (if (floatp pixelsize) (round pixelsize)))))) 396 (if (floatp pixelsize) (round pixelsize) pixelsize)))))
397 397
398 (defun x-font-size-core (font) 398 (defun x-font-size-core (font)
399 (if (font-instance-p font) (setq font (font-instance-name font))) 399 (if (font-instance-p font) (setq font (font-instance-name font)))
400 (cond ((or (string-match x-font-regexp font) 400 (cond ((or (string-match x-font-regexp font)
401 (string-match x-font-regexp-head-2 font)) 401 (string-match x-font-regexp-head-2 font))
519 (x-find-smaller-font-core font device) 519 (x-find-smaller-font-core font device)
520 (x-find-smaller-font-xft font device)) 520 (x-find-smaller-font-xft font device))
521 (x-find-smaller-font-core font device))) 521 (x-find-smaller-font-core font device)))
522 522
523 (defun x-find-xft-font-of-size (font new-size-proc &optional device) 523 (defun x-find-xft-font-of-size (font new-size-proc &optional device)
524 (let* ((pattern (fc-font-real-pattern 524 (let* ((pattern (fc-font-match (or device (default-x-device))
525 font (or device (default-x-device))))) 525 (fc-name-parse font))))
526 (when pattern 526 (when pattern
527 (let ((size (fc-pattern-get-size pattern 0))) 527 (let ((size (fc-pattern-get-size pattern 0)))
528 (if (floatp size) 528 (if (floatp size)
529 (let ((copy (fc-pattern-duplicate pattern))) 529 (let ((copy (fc-pattern-duplicate pattern)))
530 (fc-pattern-del-size copy) 530 (fc-pattern-del-size copy)