Mercurial > hg > xemacs-beta

comparison lisp/x-font-menu.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents a300bb07d72d
children 697ef44129c6
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
2 2
3 ;; Copyright (C) 1994 Free Software Foundation, Inc. 3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. 4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1997 Sun Microsystems 5 ;; Copyright (C) 1997 Sun Microsystems
6 6
7 ;; Author: Jamie Zawinski <jwz@netscape.com> 7 ;; Author: Jamie Zawinski <jwz@jwz.org>
8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com> 8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
9 ;; Mule-ized by: Martin Buchholz 9 ;; Mule-ized by: Martin Buchholz
10 ;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org>
10 11
11 ;; This file is part of XEmacs. 12 ;; This file is part of XEmacs.
12 13
13 ;; XEmacs is free software; you can redistribute it and/or modify it 14 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by 15 ;; under the terms of the GNU General Public License as published by
22 23
23 ;; You should have received a copy of the GNU General Public License 24 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING. If not, write to the 25 ;; along with XEmacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, 59 Temple Place - Suite 330, 26 ;; Free Software Foundation, 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA. 27 ;; Boston, MA 02111-1307, USA.
27
28 ;;; Commentary:
29 ;;;
30 ;;; Creates three menus, "Font", "Size", and "Weight", and puts them on the
31 ;;; "Options" menu. The contents of these menus are the superset of those
32 ;;; properties available on any fonts, but only the intersection of the three
33 ;;; sets is selectable at one time.
34 ;;;
35 ;;; Known Problems:
36 ;;; ===============
37 ;;; Items on the Font menu are selectable if and only if that font exists in
38 ;;; the same size and weight as the current font. This means that some fonts
39 ;;; are simply not reachable from some other fonts - if only one font comes
40 ;;; in only one point size (like "Nil", which comes only in 2), you will never
41 ;;; be able to select it. It would be better if the items on the Fonts menu
42 ;;; were always selectable, and selecting them would set the size to be the
43 ;;; closest size to the current font's size.
44 ;;;
45 ;;; This attempts to change all other faces in an analagous way to the change
46 ;;; that was made to the default face; if it can't, it will skip over the face.
47 ;;; However, this could leave incongruous font sizes around, which may cause
48 ;;; some nonreversibility problems if further changes are made. Perhaps it
49 ;;; should remember the initial fonts of all faces, and derive all subsequent
50 ;;; fonts from that initial state.
51 ;;;
52 ;;; xfontsel(1) is a lot more flexible (but probably harder to understand).
53 ;;;
54 ;;; The code to construct menus from all of the x11 fonts available from the
55 ;;; server is autoloaded and executed the very first time that one of the Font
56 ;;; menus is selected on each device. That is, if XEmacs has frames on two
57 ;;; different devices, then separate font menu information will be maintained
58 ;;; for each X display. If the font path changes after emacs has already
59 ;;; asked the X server on a particular display for its list of fonts, this
60 ;;; won't notice. Also, the first time that a font menu is posted on each
61 ;;; display will entail a lengthy delay, but that's better than slowing down
62 ;;; XEmacs startup. At any time (i.e.: after a font-path change or
63 ;;; immediately after device creation), you can call
64 ;;; `reset-device-font-menus' to rebuild the menus from all currently
65 ;;; available fonts.
66 ;;;
67 ;;; There is knowledge here about the regexp match numbers in
68 ;;; `x-font-regexp' and `x-font-regexp-foundry-and-family' defined in
69 ;;; x-faces.el.
70 ;;;
71 ;;; There are at least three kinds of fonts under X11r5:
72 ;;;
73 ;;; - bitmap fonts, which can be assumed to look as good as possible;
74 ;;; - bitmap fonts which have been (or can be) automatically scaled to
75 ;;; a new size, and which almost always look awful;
76 ;;; - and true outline fonts, which should look ok at any size, but in
77 ;;; practice (on at least some systems) look awful at any size, and
78 ;;; even in theory are unlikely ever to look as good as non-scaled
79 ;;; bitmap fonts.
80 ;;;
81 ;;; It would be nice to get this code to look for non-scaled bitmap fonts
82 ;;; first, then outline fonts, then scaled bitmap fonts as a last resort.
83 ;;; But it's not clear to me how to tell them apart based on their truenames
84 ;;; and/or the result of XListFonts(). I welcome any and all explanations
85 ;;; of the subtleties involved...
86 ;;;
87 ;;;
88 ;;; If You Think You'Re Seeing A Bug:
89 ;;; =================================
90 ;;; When reporting problems, send the following information:
91 ;;;
92 ;;; - Exactly what behavior you're seeing;
93 ;;; - The output of the `xlsfonts' program;
94 ;;; - The value of the variable `device-fonts-cache';
95 ;;; - The values of the following expressions, both before and after
96 ;;; making a selection from any of the fonts-related menus:
97 ;;; (face-font 'default)
98 ;;; (font-truename (face-font 'default))
99 ;;; (font-properties (face-font 'default))
100 ;;; - The values of the following variables after making a selection:
101 ;;; font-menu-preferred-resolution
102 ;;; font-menu-registry-encoding
103 ;;;
104 ;;; There is a common misconception that "*-courier-medium-r-*-11-*", also
105 ;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1",
106 ;;; is an 11-point font. It is not -- it is an 11-pixel font at 100dpi,
107 ;;; which is an 8-point font (the number after -11- is the size in tenths
108 ;;; of points). So if you expect to be seeing an "11" entry in the "Size"
109 ;;; menu and are not, this may be why.
110 ;;;
111 ;;; In the real world (aka Solaris), one has to deal with fonts that
112 ;;; appear to be medium-i but are really light-r, and fonts that
113 ;;; resolve to different resolutions depending on the charset:
114 ;;;
115 ;;; (font-instance-truename
116 ;;; (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*"))
117 ;;; ==>
118 ;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0"
119 ;;;
120 ;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*")
121 ;;; ==>
122 ;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1"
123 ;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0"
124 ;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0")
125
126 ;;; Code: 28 ;;; Code:
127 29
128 ;; #### - implement these... 30 ;; #### - implement these...
129 ;; 31 ;;
130 ;;; (defvar font-menu-ignore-proportional-fonts nil 32 ;;; (defvar font-menu-ignore-proportional-fonts nil
131 ;;; "*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.")
132 34
133 ;;;###autoload 35 (require 'font-menu)
134 (defcustom font-menu-ignore-scaled-fonts t 36
135 "*If non-nil, then the font menu will try to show only bitmap fonts." 37 (defvar x-font-menu-registry-encoding nil
136 :type 'boolean
137 :group 'x)
138
139 ;;;###autoload
140 (defcustom font-menu-this-frame-only-p nil
141 "*If non-nil, then changing the default font from the font menu will only
142 affect one frame instead of all frames."
143 :type 'boolean
144 :group 'x)
145
146 ;; only call XListFonts (and parse) once per device.
147 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
148 (defvar device-fonts-cache nil)
149
150 (defvar font-menu-registry-encoding nil
151 "Registry and encoding to use with font menu fonts.") 38 "Registry and encoding to use with font menu fonts.")
152 39
153 (defvar font-menu-preferred-resolution "*-*" 40 (defvar x-fonts-menu-junk-families
154 "Preferred horizontal and vertical font menu resolution (e.g. \"75-75\").")
155
156 (defvar fonts-menu-junk-families
157 (purecopy 41 (purecopy
158 (mapconcat 42 (mapconcat
159 #'identity 43 #'identity
160 '("cursor" "glyph" "symbol" ; Obvious losers. 44 '("cursor" "glyph" "symbol" ; Obvious losers.
161 "\\`Ax...\\'" ; FrameMaker fonts - there are just way too 45 "\\`Ax...\\'" ; FrameMaker fonts - there are just way too
164 ; "Axcor" -> "Applix Courier Roman", 48 ; "Axcor" -> "Applix Courier Roman",
165 ; "Axcob" -> "Applix Courier Bold", etc. 49 ; "Axcob" -> "Applix Courier Bold", etc.
166 ) 50 )
167 "\\|")) 51 "\\|"))
168 "A regexp matching font families which are uninteresting (e.g. cursor fonts).") 52 "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
169
170 (eval-when-compile
171 (defsubst device-fonts-cache ()
172 (or (cdr (assq (selected-device) device-fonts-cache))
173 (reset-device-font-menus (selected-device)))))
174 53
175 (defun hack-font-truename (fn) 54 (defun hack-font-truename (fn)
176 "Filter the output of `font-instance-truename' to deal with Japanese fontsets." 55 "Filter the output of `font-instance-truename' to deal with Japanese fontsets."
177 (if (string-match "," (font-instance-truename fn)) 56 (if (string-match "," (font-instance-truename fn))
178 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-"))) 57 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-")))
184 (setq flist (cdr flist)) 63 (setq flist (cdr flist))
185 )) 64 ))
186 ret) 65 ret)
187 (font-instance-truename fn))) 66 (font-instance-truename fn)))
188 67
189 ;;;###autoload
190 (fset 'install-font-menus 'reset-device-font-menus)
191 (make-obsolete 'install-font-menus 'reset-device-font-menus)
192
193 (defvar x-font-regexp-ascii nil 68 (defvar x-font-regexp-ascii nil
194 "This is used to filter out font families that can't display ASCII text. 69 "This is used to filter out font families that can't display ASCII text.
195 It must be set at run-time.") 70 It must be set at run-time.")
196 71
197 (defun vassoc (key valist)
198 "Search VALIST for a vector whose first element is equal to KEY.
199 See also `assoc'."
200 ;; by Stig@hackvan.com
201 (let (el)
202 (catch 'done
203 (while (setq el (pop valist))
204 (and (equal key (aref el 0))
205 (throw 'done el))))))
206
207 ;;;###autoload 72 ;;;###autoload
208 (defun reset-device-font-menus (&optional device debug) 73 (defun x-reset-device-font-menus (device &optional debug)
209 "Generates the `Font', `Size', and `Weight' submenus for the Options menu. 74 "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
210 This is run the first time that a font-menu is needed for each device. 75 This is run the first time that a font-menu is needed for each device.
211 If you don't like the lazy invocation of this function, you can add it to 76 If you don't like the lazy invocation of this function, you can add it to
212 `create-device-hook' and that will make the font menus respond more quickly 77 `create-device-hook' and that will make the font menus respond more quickly
213 when they are selected for the first time. If you add fonts to your system, 78 when they are selected for the first time. If you add fonts to your system,
214 or if you change your font path, you can call this to re-initialize the menus." 79 or if you change your font path, you can call this to re-initialize the menus."
215 ;; by Stig@hackvan.com 80 ;; by Stig@hackvan.com
216 ;; #### - this should implement a `menus-only' option, which would 81 ;; #### - this should implement a `menus-only' option, which would
217 ;; recalculate the menus from the cache w/o having to do list-fonts again. 82 ;; recalculate the menus from the cache w/o having to do list-fonts again.
218 (message "Getting list of fonts from server... ") 83 (unless x-font-regexp-ascii
219 (if (or noninteractive 84 (setq x-font-regexp-ascii (if (featurep 'mule)
220 (not (or device (setq device (selected-device)))) 85 (charset-registry 'ascii)
221 (not (eq (device-type device) 'x))) 86 "iso8859-1")))
222 nil 87 (setq x-font-menu-registry-encoding
223 (unless x-font-regexp-ascii 88 (if (featurep 'mule) "*-*" "iso8859-1"))
224 (setq x-font-regexp-ascii (if (featurep 'mule) 89 (let ((case-fold-search t)
225 (charset-registry 'ascii) 90 family size weight entry monospaced-p
226 "iso8859-1"))) 91 dev-cache cache families sizes weights)
227 (setq font-menu-registry-encoding 92 (dolist (name (cond ((null debug) ; debugging kludge
228 (if (featurep 'mule) "*-*" "iso8859-1")) 93 (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
229 (let ((case-fold-search t) 94 ((stringp debug) (split-string debug "\n"))
230 family size weight entry monospaced-p 95 (t debug)))
231 dev-cache cache families sizes weights) 96 (when (and (string-match x-font-regexp-ascii name)
232 (dolist (name (cond ((null debug) ; debugging kludge 97 (string-match x-font-regexp name))
233 (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)) 98 (setq weight (capitalize (match-string 1 name))
234 ((stringp debug) (split-string debug "\n")) 99 size (string-to-int (match-string 6 name)))
235 (t debug))) 100 (or (string-match x-font-regexp-foundry-and-family name)
236 (when (and (string-match x-font-regexp-ascii name) 101 (error "internal error"))
237 (string-match x-font-regexp name)) 102 (setq family (capitalize (match-string 1 name)))
238 (setq weight (capitalize (match-string 1 name)) 103 (or (string-match x-font-regexp-spacing name)
239 size (string-to-int (match-string 6 name))) 104 (error "internal error"))
240 (or (string-match x-font-regexp-foundry-and-family name) 105 (setq monospaced-p (string= "m" (match-string 1 name)))
241 (error "internal error")) 106 (unless (string-match x-fonts-menu-junk-families family)
242 (setq family (capitalize (match-string 1 name))) 107 (setq entry (or (vassoc family cache)
243 (or (string-match x-font-regexp-spacing name) 108 (car (setq cache
244 (error "internal error")) 109 (cons (vector family nil nil t)
245 (setq monospaced-p (string= "m" (match-string 1 name))) 110 cache)))))
246 (unless (string-match fonts-menu-junk-families family) 111 (or (member family families) (push family families))
247 (setq entry (or (vassoc family cache) 112 (or (member weight weights) (push weight weights))
248 (car (setq cache 113 (or (member size sizes) (push size sizes))
249 (cons (vector family nil nil t) 114 (or (member weight (aref entry 1)) (push weight (aref entry 1)))
250 cache))))) 115 (or (member size (aref entry 2)) (push size (aref entry 2)))
251 (or (member family families) (push family families)) 116 (aset entry 3 (and (aref entry 3) monospaced-p)))))
252 (or (member weight weights) (push weight weights)) 117 ;;
253 (or (member size sizes) (push size sizes)) 118 ;; Hack scalable fonts.
254 (or (member weight (aref entry 1)) (push weight (aref entry 1))) 119 ;; Some fonts come only in scalable versions (the only size is 0)
255 (or (member size (aref entry 2)) (push size (aref entry 2))) 120 ;; and some fonts come in both scalable and non-scalable versions
256 (aset entry 3 (and (aref entry 3) monospaced-p))))) 121 ;; (one size is 0). If there are any scalable fonts at all, make
257 ;; 122 ;; sure that the union of all point sizes contains at least some
258 ;; Hack scalable fonts. 123 ;; common sizes - it's possible that some sensible sizes might end
259 ;; Some fonts come only in scalable versions (the only size is 0) 124 ;; up not getting mentioned explicitly.
260 ;; and some fonts come in both scalable and non-scalable versions 125 ;;
261 ;; (one size is 0). If there are any scalable fonts at all, make 126 (if (member 0 sizes)
262 ;; sure that the union of all point sizes contains at least some 127 (let ((common '(60 80 100 120 140 160 180 240)))
263 ;; common sizes - it's possible that some sensible sizes might end 128 (while common
264 ;; up not getting mentioned explicitly. 129 (or;;(member (car common) sizes) ; not enough slack
265 ;; 130 (let ((rest sizes)
266 (if (member 0 sizes) 131 (done nil))
267 (let ((common '(60 80 100 120 140 160 180 240))) 132 (while (and (not done) rest)
268 (while common 133 (if (and (> (car common) (- (car rest) 5))
269 (or;;(member (car common) sizes) ; not enough slack 134 (< (car common) (+ (car rest) 5)))
270 (let ((rest sizes) 135 (setq done t))
271 (done nil)) 136 (setq rest (cdr rest)))
272 (while (and (not done) rest) 137 done)
273 (if (and (> (car common) (- (car rest) 5)) 138 (setq sizes (cons (car common) sizes)))
274 (< (car common) (+ (car rest) 5))) 139 (setq common (cdr common)))
275 (setq done t)) 140 (setq sizes (delq 0 sizes))))
276 (setq rest (cdr rest))) 141
277 done) 142 (setq families (sort families 'string-lessp)
278 (setq sizes (cons (car common) sizes))) 143 weights (sort weights 'string-lessp)
279 (setq common (cdr common))) 144 sizes (sort sizes '<))
280 (setq sizes (delq 0 sizes)))) 145
281 146 (dolist (entry cache)
282 (setq families (sort families 'string-lessp) 147 (aset entry 1 (sort (aref entry 1) 'string-lessp))
283 weights (sort weights 'string-lessp) 148 (aset entry 2 (sort (aref entry 2) '<)))
284 sizes (sort sizes '<)) 149
285 150 (setq dev-cache (assq device device-fonts-cache))
286 (dolist (entry cache) 151 (or dev-cache
287 (aset entry 1 (sort (aref entry 1) 'string-lessp)) 152 (setq dev-cache (car (push (list device) device-fonts-cache))))
288 (aset entry 2 (sort (aref entry 2) '<))) 153 (setcdr
289 154 dev-cache
290 (message "Getting list of fonts from server... done.") 155 (vector
291 156 cache
292 (setq dev-cache (assq device device-fonts-cache)) 157 (mapcar (lambda (x)
293 (or dev-cache 158 (vector x
294 (setq dev-cache (car (push (list device) device-fonts-cache)))) 159 (list 'font-menu-set-font x nil nil)
295 (setcdr 160 ':style 'radio ':active nil ':selected nil))
296 dev-cache 161 families)
297 (vector 162 (mapcar (lambda (x)
298 cache 163 (vector (if (/= 0 (% x 10))
299 (mapcar (lambda (x) 164 ;; works with no LISP_FLOAT_TYPE
300 (vector x 165 (concat (int-to-string (/ x 10)) "."
301 (list 'font-menu-set-font x nil nil) 166 (int-to-string (% x 10)))
302 ':style 'radio ':active nil ':selected nil)) 167 (int-to-string (/ x 10)))
303 families) 168 (list 'font-menu-set-font nil nil x)
304 (mapcar (lambda (x) 169 ':style 'radio ':active nil ':selected nil))
305 (vector (if (/= 0 (% x 10)) 170 sizes)
306 ;; works with no LISP_FLOAT_TYPE 171 (mapcar (lambda (x)
307 (concat (int-to-string (/ x 10)) "." 172 (vector x
308 (int-to-string (% x 10))) 173 (list 'font-menu-set-font nil x nil)
309 (int-to-string (/ x 10))) 174 ':style 'radio ':active nil ':selected nil))
310 (list 'font-menu-set-font nil nil x) 175 weights)))
311 ':style 'radio ':active nil ':selected nil)) 176 (cdr dev-cache)))
312 sizes)
313 (mapcar (lambda (x)
314 (vector x
315 (list 'font-menu-set-font nil x nil)
316 ':style 'radio ':active nil ':selected nil))
317 weights)))
318 (cdr dev-cache))))
319 177
320 ;; Extract font information from a face. We examine both the 178 ;; Extract font information from a face. We examine both the
321 ;; user-specified font name and the canonical (`true') font name. 179 ;; user-specified font name and the canonical (`true') font name.
322 ;; These can appear to have totally different properties. 180 ;; These can appear to have totally different properties.
323 ;; For examples, see the prolog above. 181 ;; For examples, see the prolog above.
324 182
325 ;; We use the user-specified one if possible, else use the truename. 183 ;; We use the user-specified one if possible, else use the truename.
326 ;; If the user didn't specify one (with "-dt-*-*", for example) 184 ;; If the user didn't specify one (with "-dt-*-*", for example)
327 ;; get the truename and use the possibly suboptimal data from that. 185 ;; get the truename and use the possibly suboptimal data from that.
328 (defun* font-menu-font-data (face dcache) 186 ;;;###autoload
187 (defun* x-font-menu-font-data (face dcache)
329 (let* ((case-fold-search t) 188 (let* ((case-fold-search t)
330 (domain (if font-menu-this-frame-only-p 189 (domain (if font-menu-this-frame-only-p
331 (selected-frame) 190 (selected-frame)
332 (selected-device))) 191 (selected-device)))
333 (name (font-instance-name (face-font-instance face domain))) 192 (name (font-instance-name (face-font-instance face domain)))
341 (when (and (null entry) 200 (when (and (null entry)
342 (string-match x-font-regexp-foundry-and-family truename)) 201 (string-match x-font-regexp-foundry-and-family truename))
343 (setq family (capitalize (match-string 1 truename))) 202 (setq family (capitalize (match-string 1 truename)))
344 (setq entry (vassoc family (aref dcache 0)))) 203 (setq entry (vassoc family (aref dcache 0))))
345 (when (null entry) 204 (when (null entry)
346 (return-from font-menu-font-data (make-vector 5 nil))) 205 (return-from x-font-menu-font-data (make-vector 5 nil)))
347 206
348 (when (string-match x-font-regexp name) 207 (when (string-match x-font-regexp name)
349 (setq weight (capitalize (match-string 1 name))) 208 (setq weight (capitalize (match-string 1 name)))
350 (setq size (string-to-int (match-string 6 name)))) 209 (setq size (string-to-int (match-string 6 name))))
351 210
356 (setq size (string-to-int (match-string 6 truename)))) 215 (setq size (string-to-int (match-string 6 truename))))
357 (setq slant (capitalize (match-string 2 truename)))) 216 (setq slant (capitalize (match-string 2 truename))))
358 217
359 (vector entry family size weight slant))) 218 (vector entry family size weight slant)))
360 219
361 ;;;###autoload 220 (defun x-font-menu-load-font (family weight size slant resolution)
362 (defun font-menu-family-constructor (ignored)
363 (catch 'menu
364 (unless (eq 'x (device-type (selected-device)))
365 (throw 'menu '(["Cannot parse current font" ding nil])))
366 (let* ((dcache (device-fonts-cache))
367 (font-data (font-menu-font-data 'default dcache))
368 (entry (aref font-data 0))
369 (family (aref font-data 1))
370 (size (aref font-data 2))
371 (weight (aref font-data 3))
372 f)
373 (unless family
374 (throw 'menu '(["Cannot parse current font" ding nil])))
375 ;; Items on the Font menu are enabled iff that font exists in
376 ;; the same size and weight as the current font (scalable fonts
377 ;; exist in every size). Only the current font is marked as
378 ;; selected.
379 (mapcar
380 (lambda (item)
381 (setq f (aref item 0)
382 entry (vassoc f (aref dcache 0)))
383 (if (and (member weight (aref entry 1))
384 (or (member size (aref entry 2))
385 (and (not font-menu-ignore-scaled-fonts)
386 (member 0 (aref entry 2)))))
387 (enable-menu-item item)
388 (disable-menu-item item))
389 (if (string-equal family f)
390 (select-toggle-menu-item item)
391 (deselect-toggle-menu-item item))
392 item)
393 (aref dcache 1)))))
394
395 ;;;###autoload
396 (defun font-menu-size-constructor (ignored)
397 (catch 'menu
398 (unless (eq 'x (device-type (selected-device)))
399 (throw 'menu '(["Cannot parse current font" ding nil])))
400 (let* ((dcache (device-fonts-cache))
401 (font-data (font-menu-font-data 'default dcache))
402 (entry (aref font-data 0))
403 (family (aref font-data 1))
404 (size (aref font-data 2))
405 ;;(weight (aref font-data 3))
406 s)
407 (unless family
408 (throw 'menu '(["Cannot parse current font" ding nil])))
409 ;; Items on the Size menu are enabled iff current font has
410 ;; that size. Only the size of the current font is selected.
411 ;; (If the current font comes in size 0, it is scalable, and
412 ;; thus has every size.)
413 (mapcar
414 (lambda (item)
415 (setq s (nth 3 (aref item 1)))
416 (if (or (member s (aref entry 2))
417 (and (not font-menu-ignore-scaled-fonts)
418 (member 0 (aref entry 2))))
419 (enable-menu-item item)
420 (disable-menu-item item))
421 (if (eq size s)
422 (select-toggle-menu-item item)
423 (deselect-toggle-menu-item item))
424 item)
425 (aref dcache 2)))))
426
427 ;;;###autoload
428 (defun font-menu-weight-constructor (ignored)
429 (catch 'menu
430 (unless (eq 'x (device-type (selected-device)))
431 (throw 'menu '(["Cannot parse current font" ding nil])))
432 (let* ((dcache (device-fonts-cache))
433 (font-data (font-menu-font-data 'default dcache))
434 (entry (aref font-data 0))
435 (family (aref font-data 1))
436 ;;(size (aref font-data 2))
437 (weight (aref font-data 3))
438 w)
439 (unless family
440 (throw 'menu '(["Cannot parse current font" ding nil])))
441 ;; Items on the Weight menu are enabled iff current font
442 ;; has that weight. Only the weight of the current font
443 ;; is selected.
444 (mapcar
445 (lambda (item)
446 (setq w (aref item 0))
447 (if (member w (aref entry 1))
448 (enable-menu-item item)
449 (disable-menu-item item))
450 (if (string-equal weight w)
451 (select-toggle-menu-item item)
452 (deselect-toggle-menu-item item))
453 item)
454 (aref dcache 3)))))
455
456
457 ;;; Changing font sizes
458
459 (defun font-menu-set-font (family weight size)
460 ;; This is what gets run when an item is selected from any of the three
461 ;; fonts menus. It needs to be rather clever.
462 ;; (size is measured in 10ths of points.)
463 (let* ((dcache (device-fonts-cache))
464 (font-data (font-menu-font-data 'default dcache))
465 (from-family (aref font-data 1))
466 (from-size (aref font-data 2))
467 (from-weight (aref font-data 3))
468 (from-slant (aref font-data 4))
469 new-default-face-font
470 new-props)
471 (unless from-family
472 (signal 'error '("couldn't parse font name for default face")))
473 (when weight
474 (signal 'error '("Setting weight currently not supported")))
475 (setq new-default-face-font
476 (font-menu-load-font (or family from-family)
477 (or weight from-weight)
478 (or size from-size)
479 from-slant
480 font-menu-preferred-resolution))
481 (dolist (face (delq 'default (face-list)))
482 (when (face-font-instance face)
483 (message "Changing font of `%s'..." face)
484 (condition-case c
485 (font-menu-change-face face
486 from-family from-weight from-size
487 family weight size)
488 (error
489 (display-error c nil)
490 (sit-for 1)))))
491 ;; Set the default face's font after hacking the other faces, so that
492 ;; the frame size doesn't change until we are all done.
493
494 ;; If we need to be frame local we do the changes ourselves.
495 (if font-menu-this-frame-only-p
496 ;;; WMP - we need to honor font-menu-this-frame-only-p here!
497 (set-face-font 'default new-default-face-font
498 (and font-menu-this-frame-only-p (selected-frame)))
499 ;; OK Let Customize do it.
500 (when (and family (not (equal family from-family)))
501 (setq new-props (append (list :family family) new-props)))
502 (when (and size (not (equal size from-size)))
503 (setq new-props (append
504 (list :size (concat (int-to-string (/ size 10)) "pt")) new-props)))
505 (custom-set-face-update-spec 'default '((type x)) new-props)
506 (message "Font %s" (face-font-name 'default)))))
507
508
509 (defun font-menu-change-face (face
510 from-family from-weight from-size
511 to-family to-weight to-size)
512 (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
513 (let* ((dcache (device-fonts-cache))
514 (font-data (font-menu-font-data face dcache))
515 (face-family (aref font-data 1))
516 (face-size (aref font-data 2))
517 (face-weight (aref font-data 3))
518 (face-slant (aref font-data 4)))
519
520 (or face-family
521 (signal 'error (list "couldn't parse font name for face" face)))
522
523 ;; If this face matches the old default face in the attribute we
524 ;; are changing, then change it to the new attribute along that
525 ;; dimension. Also, the face must have its own global attribute.
526 ;; If its value is inherited, we don't touch it. If any of this
527 ;; is not true, we leave it alone.
528 (when (and (face-font face 'global)
529 (cond
530 (to-family (string-equal face-family from-family))
531 (to-weight (string-equal face-weight from-weight))
532 (to-size (= face-size from-size))))
533 (set-face-font face
534 (font-menu-load-font (or to-family face-family)
535 (or to-weight face-weight)
536 (or to-size face-size)
537 face-slant
538 font-menu-preferred-resolution)
539 (and font-menu-this-frame-only-p
540 (selected-frame))))))
541
542 (defun font-menu-load-font (family weight size slant resolution)
543 "Try to load a font with the requested properties. 221 "Try to load a font with the requested properties.
544 The weight, slant and resolution are only hints." 222 The weight, slant and resolution are only hints."
545 (when (integerp size) (setq size (int-to-string size))) 223 (when (integerp size) (setq size (int-to-string size)))
546 (let (font) 224 (let (font)
547 (catch 'got-font 225 (catch 'got-font
557 (list resolution "*-*"))) 235 (list resolution "*-*")))
558 (when (setq font 236 (when (setq font
559 (make-font-instance 237 (make-font-instance
560 (concat "-*-" family "-" weight "-" slant "-*-*-*-" 238 (concat "-*-" family "-" weight "-" slant "-*-*-*-"
561 size "-" resolution "-*-*-" 239 size "-" resolution "-*-*-"
562 font-menu-registry-encoding) 240 x-font-menu-registry-encoding)
563 nil t)) 241 nil t))
564 (throw 'got-font font)))))))) 242 (throw 'got-font font))))))))
565 243
566 (defun flush-device-fonts-cache (device)
567 ;; by Stig@hackvan.com
568 (let ((elt (assq device device-fonts-cache)))
569 (and elt
570 (setq device-fonts-cache (delq elt device-fonts-cache)))))
571
572 (add-hook 'delete-device-hook 'flush-device-fonts-cache)
573
574 (provide 'x-font-menu) 244 (provide 'x-font-menu)
575 245
576 ;;; x-font-menu.el ends here 246 ;;; x-font-menu.el ends here