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