1 ;; font-menu.el --- Managing menus of fonts.
3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1997 Sun Microsystems
7 ;; Adapted from x-font-menu.el by Andy Piper <andy@xemacs.org>
9 ;; This file is part of XEmacs.
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)
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.
21 ;; You should have received a copy of the GNU General Public License
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.
26 ;; This file contains the device-nospecific font menu stuff
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.
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.
45 ;;; This attempts to change all other faces in an analogous 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.
52 ;;; xfontsel(1) is a lot more flexible (but probably harder to understand).
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
67 ;;; There is knowledge here about the regexp match numbers in
68 ;;; `mswindows-font-regexp' and `mswindows-font-regexp-foundry-and-family' defined in
69 ;;; mswindows-faces.el.
71 ;;; There are at least three kinds of fonts under X11r5:
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
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...
88 ;;; If You Think You'Re Seeing A Bug:
89 ;;; =================================
90 ;;; When reporting problems, send the following information:
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
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.
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:
115 ;;; (font-instance-truename
116 ;;; (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*"))
118 ;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0"
120 ;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*")
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")
127 (defcustom font-menu-ignore-scaled-fonts nil
128 "*If non-nil, then the font menu will try to show only bitmap fonts."
133 (defcustom font-menu-this-frame-only-p nil
134 "*If non-nil, then changing the default font from the font menu will only
135 affect one frame instead of all frames."
139 (defcustom font-menu-max-items 25
140 "*Maximum number of items in the font menu
141 If number of entries in a menu is larger than this value, split menu
142 into submenus of nearly equal length. If nil, never split menu into
145 :type '(choice (const :tag "no submenus" nil)
148 (defcustom font-menu-submenu-name-format "%-12.12s ... %.12s"
149 "*Format specification of the submenu name.
150 Used by `font-menu-split-long-menu' if the number of entries in a menu is
151 larger than `font-menu-menu-max-items'.
152 This string should contain one %s for the name of the first entry and
153 one %s for the name of the last entry in the submenu.
154 If the value is a function, it should return the submenu name. The
155 function is be called with two arguments, the names of the first and
156 the last entry in the menu."
158 :type '(choice (string :tag "Format string")
161 (defvar font-menu-preferred-resolution
162 (make-specifier-and-init 'generic '((global ((mswindows) . ":")
165 "Preferred horizontal and vertical font menu resolution (e.g. \"75:75\").")
167 (defvar font-menu-size-scaling
168 (make-specifier-and-init 'integer '((global ((mswindows) . 1)
171 "Scale factor used in defining font sizes.")
173 ;; only call XListFonts (and parse) once per device.
174 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
175 (defvar device-fonts-cache nil)
177 (defsubst device-fonts-cache ()
178 (or (cdr (assq (selected-device) device-fonts-cache))
179 (and (reset-device-font-menus (selected-device))
180 (cdr (assq (selected-device) device-fonts-cache)))))
183 (fset 'install-font-menus 'reset-device-font-menus)
184 (make-obsolete 'install-font-menus 'reset-device-font-menus)
187 (defun reset-device-font-menus (&optional device debug)
188 "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
189 This is run the first time that a font-menu is needed for each device.
190 If you don't like the lazy invocation of this function, you can add it to
191 `create-device-hook' and that will make the font menus respond more quickly
192 when they are selected for the first time. If you add fonts to your system,
193 or if you change your font path, you can call this to re-initialize the menus."
194 (message "Getting list of fonts from server... ")
195 (if (or noninteractive
196 (not (or device (setq device (selected-device)))))
198 (call-device-method 'reset-device-font-menus device device debug)
199 (message "Getting list of fonts from server... done.")))
201 (defun font-menu-split-long-menu (menu)
202 "Split MENU according to `font-menu-max-items' and add accelerator specs."
203 (let ((len (length menu)))
204 (if (or (null font-menu-max-items)
205 (null (featurep 'lisp-float-type))
206 (<= len font-menu-max-items))
207 (submenu-generate-accelerator-spec menu)
208 ;; Submenu is max 2 entries longer than menu, never shorter, number of
209 ;; entries in submenus differ by at most one (with longer submenus first)
210 (let* ((outer (floor (sqrt len)))
211 (inner (/ len outer))
214 (setq menu (reverse menu))
221 sub (cons (car menu) sub)
224 (cons (cons (if (stringp font-menu-submenu-name-format)
225 (format font-menu-submenu-name-format
226 (menu-item-strip-accelerator-spec
228 (menu-item-strip-accelerator-spec
230 (funcall font-menu-submenu-name-format
231 (menu-item-strip-accelerator-spec
233 (menu-item-strip-accelerator-spec
235 (submenu-generate-accelerator-spec sub))
238 (if (= rest outer) (setq inner (1+ inner)))))
239 (submenu-generate-accelerator-spec result)))))
242 (defun font-menu-family-constructor (ignored)
244 (unless (console-on-window-system-p)
245 (throw 'menu '(["Cannot parse current font" ding nil])))
246 (let* ((dcache (device-fonts-cache))
247 (font-data (font-menu-font-data 'default dcache))
248 (entry (aref font-data 0))
249 (family (aref font-data 1))
250 (size (aref font-data 2))
251 (weight (aref font-data 3))
254 (throw 'menu '(["Cannot parse current font" ding nil])))
255 ;; Items on the Font menu are enabled iff that font exists in
256 ;; the same size and weight as the current font (scalable fonts
257 ;; exist in every size). Only the current font is marked as
259 (font-menu-split-long-menu
262 (setq f (menu-item-strip-accelerator-spec (aref item 0))
263 entry (vassoc f (aref dcache 0)))
264 (if (and (or (member weight (aref entry 1))
265 ;; mswindows often allows any weight
266 (member "" (aref entry 1)))
267 (or (member size (aref entry 2))
268 (and (not font-menu-ignore-scaled-fonts)
269 (member 0 (aref entry 2)))))
270 (enable-menu-item item)
271 (disable-menu-item item))
272 (if (string-equal family f)
273 (select-toggle-menu-item item)
274 (deselect-toggle-menu-item item))
278 (define-device-method* font-menu-font-data)
281 (defun font-menu-size-constructor (ignored)
283 (unless (console-on-window-system-p)
284 (throw 'menu '(["Cannot parse current font" ding nil])))
285 (let* ((dcache (device-fonts-cache))
286 (font-data (font-menu-font-data 'default dcache))
287 (entry (aref font-data 0))
288 (family (aref font-data 1))
289 (size (aref font-data 2))
290 ;;(weight (aref font-data 3))
293 (throw 'menu '(["Cannot parse current font" ding nil])))
294 ;; Items on the Size menu are enabled iff current font has
295 ;; that size. Only the size of the current font is selected.
296 ;; (If the current font comes in size 0, it is scalable, and
297 ;; thus has every size.)
300 (setq s (nth 3 (aref item 1)))
301 (if (or (member s (aref entry 2))
302 (and (not font-menu-ignore-scaled-fonts)
303 (member 0 (aref entry 2))))
304 (enable-menu-item item)
305 (disable-menu-item item))
307 (select-toggle-menu-item item)
308 (deselect-toggle-menu-item item))
310 (submenu-generate-accelerator-spec (aref dcache 2))))))
313 (defun font-menu-weight-constructor (ignored)
315 (unless (console-on-window-system-p)
316 (throw 'menu '(["Cannot parse current font" ding nil])))
317 (let* ((dcache (device-fonts-cache))
318 (font-data (font-menu-font-data 'default dcache))
319 (entry (aref font-data 0))
320 (family (aref font-data 1))
321 ;;(size (aref font-data 2))
322 (weight (aref font-data 3))
325 (throw 'menu '(["Cannot parse current font" ding nil])))
326 ;; Items on the Weight menu are enabled iff current font
327 ;; has that weight. Only the weight of the current font
331 (setq w (aref item 0))
332 (if (member w (aref entry 1))
333 (enable-menu-item item)
334 (disable-menu-item item))
335 (if (string-equal weight w)
336 (select-toggle-menu-item item)
337 (deselect-toggle-menu-item item))
339 (submenu-generate-accelerator-spec (aref dcache 3))))))
342 ;;; Changing font sizes
344 (defun font-menu-set-font (family weight size)
345 ;; This is what gets run when an item is selected from any of the three
346 ;; fonts menus. It needs to be rather clever.
347 ;; (size is measured in 10ths of points.)
348 (let* ((dcache (device-fonts-cache))
349 (font-data (font-menu-font-data 'default dcache))
350 (from-family (aref font-data 1))
351 (from-size (aref font-data 2))
352 (from-weight (aref font-data 3))
353 (from-slant (aref font-data 4))
354 (face-list-to-change (delq 'default (face-list)))
355 new-default-face-font)
357 (signal 'error '("couldn't parse font name for default face")))
359 (signal 'error '("Setting weight currently not supported")))
360 (setq new-default-face-font
362 (or family from-family)
363 (or weight from-weight)
367 font-menu-preferred-resolution (selected-device))))
368 ;; This is such a gross hack. The border-glyph face under
369 ;; mswindows is in a symbol font. Thus it will not appear in the
370 ;; cache - being a junk family. What we should do is change the
371 ;; size but not the family, but this is more work than I care to
372 ;; invest at the moment.
373 (when (eq (device-type) 'mswindows)
374 (setq face-list-to-change
375 (delq 'border-glyph face-list-to-change)))
376 (dolist (face face-list-to-change)
377 (when (face-font-instance face)
378 (message "Changing font of `%s'..." face)
380 (font-menu-change-face face
381 from-family from-weight from-size
382 (or family from-family)
383 (or weight from-weight)
386 (display-error c nil)
388 ;; Set the default face's font after hacking the other faces, so that
389 ;; the frame size doesn't change until we are all done.
391 ;; If we need to be frame local we do the changes ourselves.
392 (if font-menu-this-frame-only-p
393 ;;; WMP - we need to honor font-menu-this-frame-only-p here!
394 (set-face-font 'default new-default-face-font
395 (and font-menu-this-frame-only-p (selected-frame)))
396 ;; OK Let Customize do it.
397 (custom-set-face-update-spec 'default
398 (list (list 'type (device-type)))
399 (list :family (or family from-family)
402 (/ (or size from-size)
403 (specifier-instance font-menu-size-scaling
406 (message "Font %s" (face-font-name 'default)))))
409 (defun font-menu-change-face (face
410 from-family from-weight from-size
411 to-family to-weight to-size)
412 (check-type face symbol)
413 (let* ((dcache (device-fonts-cache))
414 (font-data (font-menu-font-data face dcache))
415 (face-family (aref font-data 1))
416 (face-size (aref font-data 2))
417 (face-weight (aref font-data 3))
418 (face-slant (aref font-data 4)))
421 (signal 'error (list "couldn't parse font name for face" face)))
423 ;; If this face matches the old default face in the attribute we
424 ;; are changing, then change it to the new attribute along that
425 ;; dimension. Also, the face must have its own global attribute.
426 ;; If its value is inherited, we don't touch it. If any of this
427 ;; is not true, we leave it alone.
428 (when (and (face-font face 'global)
430 (to-family (string-equal face-family from-family))
431 (to-weight (string-equal face-weight from-weight))
432 (to-size (= face-size from-size))))
434 (font-menu-load-font (or to-family face-family)
435 (or to-weight face-weight)
436 (or to-size face-size)
439 font-menu-preferred-resolution
441 (and font-menu-this-frame-only-p
442 (selected-frame))))))
444 (define-device-method font-menu-load-font)
446 (defun flush-device-fonts-cache (device)
447 ;; by Stig@hackvan.com
448 (let ((elt (assq device device-fonts-cache)))
450 (setq device-fonts-cache (delq elt device-fonts-cache)))))
452 (add-hook 'delete-device-hook 'flush-device-fonts-cache)
456 ;; font-menu ends here