Mercurial > hg > xemacs-beta

comparison lisp/x-font-menu.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 491f8cf78a9c
children 15fb91e3a115
comparison
equal deleted inserted replaced
3093:769dc945b085 3094:ad2f4ae9895b
31 ;; 31 ;;
32 ;;; (defvar font-menu-ignore-proportional-fonts nil 32 ;;; (defvar font-menu-ignore-proportional-fonts nil
33 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.") 33 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.")
34 34
35 (require 'font-menu) 35 (require 'font-menu)
36
37 (when (featurep 'xft-fonts)
38 (require 'xft)
39 (require 'fontconfig))
36 40
37 (globally-declare-boundp 41 (globally-declare-boundp
38 '(x-font-regexp 42 '(x-font-regexp
39 x-font-regexp-foundry-and-family 43 x-font-regexp-foundry-and-family
40 x-font-regexp-spacing)) 44 x-font-regexp-spacing))
78 82
79 (defvar x-font-regexp-ascii nil 83 (defvar x-font-regexp-ascii nil
80 "This is used to filter out font families that can't display ASCII text. 84 "This is used to filter out font families that can't display ASCII text.
81 It must be set at run-time.") 85 It must be set at run-time.")
82 86
87 ;; #### move these to font-menu.el, and maybe make them defcustoms
88 (defvar font-menu-common-sizes
89 '(60 80 100 110 120 130 140 150 160 170 180 200 220 240 300 360)
90 "List of commonly desired font sizes in decipoints.")
91
83 ;;;###autoload 92 ;;;###autoload
84 (defun x-reset-device-font-menus (device &optional debug) 93 (defun x-reset-device-font-menus (device &optional debug)
94 (if (featurep 'xft-fonts)
95 (x-reset-device-font-menus-xft device debug)
96 (x-reset-device-font-menus-core device debug)))
97
98 (defun fc-make-font-menu-entry (family)
99 (let ((weights (fc-find-available-weights-for-family family)))
100 (vector
101 family
102 (mapcar
103 '(lambda (weight-symbol)
104 (let ((pair (assoc weight-symbol
105 '((:light "Light")
106 (:medium "Medium")
107 (:demibold "Demibold")
108 (:bold "Bold")
109 (:black "Black")))))
110 (if pair (cadr pair))))
111 weights)
112 '(0)
113 nil)))
114
115 (defun x-reset-device-font-menus-xft (device &optional debug)
116 (let* ((families-1 (fc-find-available-font-families device))
117 (families (delete-if (lambda (x)
118 (string-match x-fonts-menu-junk-families x))
119 (sort families-1 'string-lessp)))
120 (data
121 (vector
122 (mapcar 'fc-make-font-menu-entry families)
123 (mapcar
124 '(lambda (family)
125 (vector family `(font-menu-set-font ,family nil nil)
126 :style 'radio :active nil :selected nil))
127 families)
128 (mapcar
129 '(lambda (size)
130 (vector
131 (number-to-string size)
132 `(font-menu-set-font nil nil ,size)
133 :style 'radio :active nil :selected nil))
134 ;; common size list in decipoints, fontconfig wants points
135 (mapcar (lambda (x) (/ x 10)) font-menu-common-sizes))
136 (mapcar
137 '(lambda (weight)
138 (vector
139 weight
140 `(font-menu-set-font nil ,weight nil)
141 :style 'radio :active nil :selected nil))
142 '("Light" "Medium" "Demibold" "Bold" "Black"))))
143 ;; get or initialize the entry for device
144 (dev-cache (or (assq device device-fonts-cache)
145 (car (push (list device) device-fonts-cache)))))
146 ;; update the device-fonts-cache entry for device in place
147 (setcdr dev-cache data)
148 data))
149
150 (defun x-reset-device-font-menus-core (device &optional debug)
85 "Generates the `Font', `Size', and `Weight' submenus for the Options menu. 151 "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
86 This is run the first time that a font-menu is needed for each device. 152 This is run the first time that a font-menu is needed for each device.
87 If you don't like the lazy invocation of this function, you can add it to 153 If you don't like the lazy invocation of this function, you can add it to
88 `create-device-hook' and that will make the font menus respond more quickly 154 `create-device-hook' and that will make the font menus respond more quickly
89 when they are selected for the first time. If you add fonts to your system, 155 when they are selected for the first time. If you add fonts to your system,
134 ;; sure that the union of all point sizes contains at least some 200 ;; sure that the union of all point sizes contains at least some
135 ;; common sizes - it's possible that some sensible sizes might end 201 ;; common sizes - it's possible that some sensible sizes might end
136 ;; up not getting mentioned explicitly. 202 ;; up not getting mentioned explicitly.
137 ;; 203 ;;
138 (if (member 0 sizes) 204 (if (member 0 sizes)
139 (let ((common '(60 80 100 120 140 160 180 240))) 205 (let ((common font-menu-common-sizes))
140 (while common 206 (while common
141 (or;;(member (car common) sizes) ; not enough slack 207 (or;;(member (car common) sizes) ; not enough slack
142 (let ((rest sizes) 208 (let ((rest sizes)
143 (done nil)) 209 (done nil))
144 (while (and (not done) rest) 210 (while (and (not done) rest)
193 ;; We use the user-specified one if possible, else use the truename. 259 ;; We use the user-specified one if possible, else use the truename.
194 ;; If the user didn't specify one (with "-dt-*-*", for example) 260 ;; If the user didn't specify one (with "-dt-*-*", for example)
195 ;; get the truename and use the possibly suboptimal data from that. 261 ;; get the truename and use the possibly suboptimal data from that.
196 ;;;###autoload 262 ;;;###autoload
197 (defun x-font-menu-font-data (face dcache) 263 (defun x-font-menu-font-data (face dcache)
264 (let* ((case-fold-search t)
265 (domain (if font-menu-this-frame-only-p
266 (selected-frame)
267 (selected-device)))
268 (name (font-instance-name (face-font-instance face domain))))
269 (if (featurep 'xft-fonts)
270 (if (xlfd-font-name-p name)
271 ;; #### this call to x-font-menu-font-data-core originally
272 ;; had 4 args, and that's probably the right way to go
273 (x-font-menu-font-data-core face dcache)
274 (x-font-menu-font-data-xft face dcache name domain))
275 ;; #### this one, too
276 (x-font-menu-font-data-core face dcache))))
277
278 (defun x-font-menu-font-data-xft (face dcache name domain)
279 (let* ((truename (font-instance-truename
280 (face-font-instance face domain
281 (if (featurep 'mule) 'ascii))))
282 entry)
283 (if (xlfd-font-name-p truename)
284 (progn
285 nil)
286 (progn
287 (let* ((pattern (fc-font-real-pattern name domain))
288 (family (and pattern
289 (fc-pattern-get-family pattern 0))))
290 (if (fc-pattern-get-successp family)
291 (setq entry (vassoc family (aref dcache 0))))
292 (if (null entry)
293 (make-vector 5 nil)
294 (let ((weight (fc-pattern-get-weight pattern 0))
295 (size (fc-pattern-get-size pattern 0))
296 (slant (fc-pattern-get-slant pattern 0)))
297 (vector
298 entry
299 (if (fc-pattern-get-successp family)
300 family)
301 (if (fc-pattern-get-successp size)
302 size)
303 (if (fc-pattern-get-successp weight)
304 (fc-font-weight-translate-to-string weight))
305 (if (fc-pattern-get-successp slant)
306 (fc-font-slant-translate-to-string slant))))))))))
307
308 (defun x-font-menu-font-data-core (face dcache)
198 (let* ((case-fold-search t) 309 (let* ((case-fold-search t)
199 (domain (if font-menu-this-frame-only-p 310 (domain (if font-menu-this-frame-only-p
200 (selected-frame) 311 (selected-frame)
201 (selected-device))) 312 (selected-device)))
202 (name (font-instance-name (face-font-instance face domain))) 313 (name (font-instance-name (face-font-instance face domain)))
227 (setq slant (capitalize (match-string 2 truename)))) 338 (setq slant (capitalize (match-string 2 truename))))
228 339
229 (vector entry family size weight slant)))) 340 (vector entry family size weight slant))))
230 341
231 (defun x-font-menu-load-font (family weight size slant resolution) 342 (defun x-font-menu-load-font (family weight size slant resolution)
343 (if (featurep 'xft-fonts)
344 (x-font-menu-load-font-xft family weight size slant resolution)
345 (x-font-menu-load-font-core family weight size slant resolution)))
346
347 (defun x-font-menu-load-font-xft (family weight size slant resolution)
348 (let ((pattern (make-fc-pattern)))
349 (fc-pattern-add pattern fc-font-name-property-family family)
350 (if weight
351 (fc-pattern-add pattern fc-font-name-property-weight
352 (fc-font-weight-translate-from-string weight)))
353 (if size
354 (fc-pattern-add pattern fc-font-name-property-size size))
355 (if slant
356 (fc-pattern-add pattern fc-font-name-property-slant
357 (fc-font-slant-translate-from-string slant)))
358 (make-font-instance (fc-name-unparse pattern))))
359
360 (defun x-font-menu-load-font-core (family weight size slant resolution)
232 "Try to load a font with the requested properties. 361 "Try to load a font with the requested properties.
233 The weight, slant and resolution are only hints." 362 The weight, slant and resolution are only hints."
234 (when (integerp size) (setq size (int-to-string size))) 363 (when (integerp size) (setq size (int-to-string size)))
235 (let (font) 364 (let (font)
236 (catch 'got-font 365 (catch 'got-font