428
+ − 1 ;; font-menu.el --- Managing menus of fonts.
+ − 2
+ − 3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
+ − 4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
+ − 5 ;; Copyright (C) 1997 Sun Microsystems
+ − 6
+ − 7 ;; Adapted from x-font-menu.el by Andy Piper <andy@xemacs.org>
+ − 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
444
+ − 22 ;; along with XEmacs; see the file COPYING. If not, write to the
428
+ − 23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
+ − 24 ;; Boston, MA 02111-1307, USA.
+ − 25
+ − 26 ;; This file contains the device-nospecific font menu stuff
+ − 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 ;;;
440
+ − 45 ;;; This attempts to change all other faces in an analogous way to the change
428
+ − 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 are at least three kinds of fonts under X11r5:
+ − 68 ;;;
+ − 69 ;;; - bitmap fonts, which can be assumed to look as good as possible;
+ − 70 ;;; - bitmap fonts which have been (or can be) automatically scaled to
+ − 71 ;;; a new size, and which almost always look awful;
+ − 72 ;;; - and true outline fonts, which should look ok at any size, but in
+ − 73 ;;; practice (on at least some systems) look awful at any size, and
+ − 74 ;;; even in theory are unlikely ever to look as good as non-scaled
+ − 75 ;;; bitmap fonts.
+ − 76 ;;;
+ − 77 ;;; It would be nice to get this code to look for non-scaled bitmap fonts
+ − 78 ;;; first, then outline fonts, then scaled bitmap fonts as a last resort.
+ − 79 ;;; But it's not clear to me how to tell them apart based on their truenames
+ − 80 ;;; and/or the result of XListFonts(). I welcome any and all explanations
+ − 81 ;;; of the subtleties involved...
+ − 82 ;;;
+ − 83 ;;;
+ − 84 ;;; If You Think You'Re Seeing A Bug:
+ − 85 ;;; =================================
+ − 86 ;;; When reporting problems, send the following information:
+ − 87 ;;;
+ − 88 ;;; - Exactly what behavior you're seeing;
+ − 89 ;;; - The output of the `xlsfonts' program;
+ − 90 ;;; - The value of the variable `device-fonts-cache';
+ − 91 ;;; - The values of the following expressions, both before and after
+ − 92 ;;; making a selection from any of the fonts-related menus:
+ − 93 ;;; (face-font 'default)
+ − 94 ;;; (font-truename (face-font 'default))
+ − 95 ;;; (font-properties (face-font 'default))
+ − 96 ;;; - The values of the following variables after making a selection:
+ − 97 ;;; font-menu-preferred-resolution
+ − 98 ;;; font-menu-registry-encoding
+ − 99 ;;;
+ − 100 ;;; There is a common misconception that "*-courier-medium-r-*-11-*", also
+ − 101 ;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1",
+ − 102 ;;; is an 11-point font. It is not -- it is an 11-pixel font at 100dpi,
+ − 103 ;;; which is an 8-point font (the number after -11- is the size in tenths
+ − 104 ;;; of points). So if you expect to be seeing an "11" entry in the "Size"
+ − 105 ;;; menu and are not, this may be why.
+ − 106 ;;;
+ − 107 ;;; In the real world (aka Solaris), one has to deal with fonts that
+ − 108 ;;; appear to be medium-i but are really light-r, and fonts that
+ − 109 ;;; resolve to different resolutions depending on the charset:
+ − 110 ;;;
+ − 111 ;;; (font-instance-truename
+ − 112 ;;; (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*"))
+ − 113 ;;; ==>
+ − 114 ;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0"
+ − 115 ;;;
+ − 116 ;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*")
+ − 117 ;;; ==>
+ − 118 ;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1"
+ − 119 ;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0"
+ − 120 ;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0")
+ − 121
+ − 122 ;;;###autoload
+ − 123 (defcustom font-menu-ignore-scaled-fonts nil
+ − 124 "*If non-nil, then the font menu will try to show only bitmap fonts."
+ − 125 :type 'boolean
+ − 126 :group 'font-menu)
+ − 127
+ − 128 ;;;###autoload
+ − 129 (defcustom font-menu-this-frame-only-p nil
+ − 130 "*If non-nil, then changing the default font from the font menu will only
+ − 131 affect one frame instead of all frames."
+ − 132 :type 'boolean
+ − 133 :group 'font-menu)
+ − 134
771
+ − 135 (defvaralias 'font-menu-max-items 'menu-max-items)
+ − 136 (defvaralias 'font-menu-submenu-name-format 'menu-submenu-name-format)
428
+ − 137
444
+ − 138 (defvar font-menu-preferred-resolution
428
+ − 139 (make-specifier-and-init 'generic '((global ((mswindows) . ":")
1102
+ − 140 ((gtk) . "*-*")
428
+ − 141 ((x) . "*-*"))) t)
+ − 142 "Preferred horizontal and vertical font menu resolution (e.g. \"75:75\").")
+ − 143
+ − 144 (defvar font-menu-size-scaling
+ − 145 (make-specifier-and-init 'integer '((global ((mswindows) . 1)
1102
+ − 146 ((gtk) . 10)
428
+ − 147 ((x) . 10))) t)
+ − 148 "Scale factor used in defining font sizes.")
+ − 149
+ − 150 ;; only call XListFonts (and parse) once per device.
+ − 151 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
+ − 152 (defvar device-fonts-cache nil)
+ − 153
+ − 154 (defsubst device-fonts-cache ()
+ − 155 (or (cdr (assq (selected-device) device-fonts-cache))
+ − 156 (and (reset-device-font-menus (selected-device))
+ − 157 (cdr (assq (selected-device) device-fonts-cache)))))
+ − 158
+ − 159 ;;;###autoload
+ − 160 (fset 'install-font-menus 'reset-device-font-menus)
+ − 161 (make-obsolete 'install-font-menus 'reset-device-font-menus)
+ − 162
+ − 163 ;;;###autoload
+ − 164 (defun reset-device-font-menus (&optional device debug)
+ − 165 "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
+ − 166 This is run the first time that a font-menu is needed for each device.
+ − 167 If you don't like the lazy invocation of this function, you can add it to
+ − 168 `create-device-hook' and that will make the font menus respond more quickly
444
+ − 169 when they are selected for the first time. If you add fonts to your system,
428
+ − 170 or if you change your font path, you can call this to re-initialize the menus."
+ − 171 (message "Getting list of fonts from server... ")
+ − 172 (if (or noninteractive
+ − 173 (not (or device (setq device (selected-device)))))
+ − 174 nil
+ − 175 (call-device-method 'reset-device-font-menus device device debug)
+ − 176 (message "Getting list of fonts from server... done.")))
+ − 177
+ − 178 ;;;###autoload
+ − 179 (defun font-menu-family-constructor (ignored)
+ − 180 (catch 'menu
+ − 181 (unless (console-on-window-system-p)
+ − 182 (throw 'menu '(["Cannot parse current font" ding nil])))
+ − 183 (let* ((dcache (device-fonts-cache))
+ − 184 (font-data (font-menu-font-data 'default dcache))
+ − 185 (entry (aref font-data 0))
+ − 186 (family (aref font-data 1))
+ − 187 (size (aref font-data 2))
+ − 188 (weight (aref font-data 3))
+ − 189 f)
+ − 190 (unless family
+ − 191 (throw 'menu '(["Cannot parse current font" ding nil])))
+ − 192 ;; Items on the Font menu are enabled iff that font exists in
+ − 193 ;; the same size and weight as the current font (scalable fonts
+ − 194 ;; exist in every size). Only the current font is marked as
+ − 195 ;; selected.
771
+ − 196 (menu-split-long-menu
428
+ − 197 (mapcar
+ − 198 (lambda (item)
442
+ − 199 (setq f (menu-item-strip-accelerator-spec (aref item 0))
428
+ − 200 entry (vassoc f (aref dcache 0)))
+ − 201 (if (and (or (member weight (aref entry 1))
+ − 202 ;; mswindows often allows any weight
+ − 203 (member "" (aref entry 1)))
+ − 204 (or (member size (aref entry 2))
+ − 205 (and (not font-menu-ignore-scaled-fonts)
+ − 206 (member 0 (aref entry 2)))))
+ − 207 (enable-menu-item item)
+ − 208 (disable-menu-item item))
+ − 209 (if (string-equal family f)
+ − 210 (select-toggle-menu-item item)
+ − 211 (deselect-toggle-menu-item item))
+ − 212 item)
+ − 213 (aref dcache 1))))))
+ − 214
+ − 215 (define-device-method* font-menu-font-data)
+ − 216
+ − 217 ;;;###autoload
+ − 218 (defun font-menu-size-constructor (ignored)
+ − 219 (catch 'menu
+ − 220 (unless (console-on-window-system-p)
+ − 221 (throw 'menu '(["Cannot parse current font" ding nil])))
+ − 222 (let* ((dcache (device-fonts-cache))
+ − 223 (font-data (font-menu-font-data 'default dcache))
+ − 224 (entry (aref font-data 0))
+ − 225 (family (aref font-data 1))
+ − 226 (size (aref font-data 2))
+ − 227 ;;(weight (aref font-data 3))
+ − 228 s)
+ − 229 (unless family
+ − 230 (throw 'menu '(["Cannot parse current font" ding nil])))
+ − 231 ;; Items on the Size menu are enabled iff current font has
+ − 232 ;; that size. Only the size of the current font is selected.
+ − 233 ;; (If the current font comes in size 0, it is scalable, and
+ − 234 ;; thus has every size.)
+ − 235 (mapcar
+ − 236 (lambda (item)
+ − 237 (setq s (nth 3 (aref item 1)))
+ − 238 (if (or (member s (aref entry 2))
+ − 239 (and (not font-menu-ignore-scaled-fonts)
+ − 240 (member 0 (aref entry 2))))
+ − 241 (enable-menu-item item)
+ − 242 (disable-menu-item item))
+ − 243 (if (eq size s)
+ − 244 (select-toggle-menu-item item)
+ − 245 (deselect-toggle-menu-item item))
+ − 246 item)
442
+ − 247 (submenu-generate-accelerator-spec (aref dcache 2))))))
428
+ − 248
+ − 249 ;;;###autoload
+ − 250 (defun font-menu-weight-constructor (ignored)
+ − 251 (catch 'menu
+ − 252 (unless (console-on-window-system-p)
+ − 253 (throw 'menu '(["Cannot parse current font" ding nil])))
+ − 254 (let* ((dcache (device-fonts-cache))
+ − 255 (font-data (font-menu-font-data 'default dcache))
+ − 256 (entry (aref font-data 0))
+ − 257 (family (aref font-data 1))
+ − 258 ;;(size (aref font-data 2))
+ − 259 (weight (aref font-data 3))
+ − 260 w)
+ − 261 (unless family
+ − 262 (throw 'menu '(["Cannot parse current font" ding nil])))
+ − 263 ;; Items on the Weight menu are enabled iff current font
+ − 264 ;; has that weight. Only the weight of the current font
+ − 265 ;; is selected.
+ − 266 (mapcar
+ − 267 (lambda (item)
+ − 268 (setq w (aref item 0))
+ − 269 (if (member w (aref entry 1))
+ − 270 (enable-menu-item item)
+ − 271 (disable-menu-item item))
+ − 272 (if (string-equal weight w)
+ − 273 (select-toggle-menu-item item)
+ − 274 (deselect-toggle-menu-item item))
+ − 275 item)
442
+ − 276 (submenu-generate-accelerator-spec (aref dcache 3))))))
428
+ − 277
+ − 278
+ − 279 ;;; Changing font sizes
+ − 280
+ − 281 (defun font-menu-set-font (family weight size)
+ − 282 ;; This is what gets run when an item is selected from any of the three
+ − 283 ;; fonts menus. It needs to be rather clever.
+ − 284 ;; (size is measured in 10ths of points.)
+ − 285 (let* ((dcache (device-fonts-cache))
+ − 286 (font-data (font-menu-font-data 'default dcache))
+ − 287 (from-family (aref font-data 1))
+ − 288 (from-size (aref font-data 2))
1102
+ − 289 (from-weight (aref font-data 3))
428
+ − 290 (from-slant (aref font-data 4))
442
+ − 291 (face-list-to-change (delq 'default (face-list)))
+ − 292 new-default-face-font)
428
+ − 293 (unless from-family
+ − 294 (signal 'error '("couldn't parse font name for default face")))
+ − 295 (when weight
+ − 296 (signal 'error '("Setting weight currently not supported")))
+ − 297 (setq new-default-face-font
872
+ − 298 (font-instance-name
+ − 299 (font-menu-load-font
+ − 300 (or family from-family)
+ − 301 (or weight from-weight)
+ − 302 (or size from-size)
+ − 303 from-slant
+ − 304 (specifier-instance
+ − 305 font-menu-preferred-resolution (selected-device)))))
+ − 306 ;; #### This is such a gross hack. The border-glyph face under
428
+ − 307 ;; mswindows is in a symbol font. Thus it will not appear in the
+ − 308 ;; cache - being a junk family. What we should do is change the
+ − 309 ;; size but not the family, but this is more work than I care to
+ − 310 ;; invest at the moment.
+ − 311 (when (eq (device-type) 'mswindows)
+ − 312 (setq face-list-to-change
+ − 313 (delq 'border-glyph face-list-to-change)))
+ − 314 (dolist (face face-list-to-change)
+ − 315 (when (face-font-instance face)
+ − 316 (message "Changing font of `%s'..." face)
+ − 317 (condition-case c
+ − 318 (font-menu-change-face face
+ − 319 from-family from-weight from-size
1102
+ − 320 (or family from-family)
+ − 321 (or weight from-weight)
+ − 322 (or size from-size))
428
+ − 323 (error
+ − 324 (display-error c nil)
+ − 325 (sit-for 1)))))
+ − 326 ;; Set the default face's font after hacking the other faces, so that
+ − 327 ;; the frame size doesn't change until we are all done.
+ − 328
+ − 329 ;; If we need to be frame local we do the changes ourselves.
+ − 330 (if font-menu-this-frame-only-p
+ − 331 ;;; WMP - we need to honor font-menu-this-frame-only-p here!
+ − 332 (set-face-font 'default new-default-face-font
+ − 333 (and font-menu-this-frame-only-p (selected-frame)))
+ − 334 ;; OK Let Customize do it.
+ − 335 (custom-set-face-update-spec 'default
442
+ − 336 (list (list 'type (device-type)))
1102
+ − 337 (list :family (or family from-family)
442
+ − 338 :size (concat
+ − 339 (int-to-string
+ − 340 (/ (or size from-size)
+ − 341 (specifier-instance font-menu-size-scaling
+ − 342 (selected-device))))
444
+ − 343 "pt")))
428
+ − 344 (message "Font %s" (face-font-name 'default)))))
+ − 345
+ − 346
+ − 347 (defun font-menu-change-face (face
+ − 348 from-family from-weight from-size
+ − 349 to-family to-weight to-size)
446
+ − 350 (check-type face symbol)
428
+ − 351 (let* ((dcache (device-fonts-cache))
+ − 352 (font-data (font-menu-font-data face dcache))
+ − 353 (face-family (aref font-data 1))
+ − 354 (face-size (aref font-data 2))
+ − 355 (face-weight (aref font-data 3))
+ − 356 (face-slant (aref font-data 4)))
+ − 357
+ − 358 (or face-family
+ − 359 (signal 'error (list "couldn't parse font name for face" face)))
+ − 360
+ − 361 ;; If this face matches the old default face in the attribute we
+ − 362 ;; are changing, then change it to the new attribute along that
+ − 363 ;; dimension. Also, the face must have its own global attribute.
+ − 364 ;; If its value is inherited, we don't touch it. If any of this
+ − 365 ;; is not true, we leave it alone.
+ − 366 (when (and (face-font face 'global)
444
+ − 367 (cond
428
+ − 368 (to-family (string-equal face-family from-family))
+ − 369 (to-weight (string-equal face-weight from-weight))
+ − 370 (to-size (= face-size from-size))))
+ − 371 (set-face-font face
872
+ − 372 (font-instance-name
+ − 373 (font-menu-load-font (or to-family face-family)
+ − 374 (or to-weight face-weight)
+ − 375 (or to-size face-size)
+ − 376 face-slant
+ − 377 (specifier-instance
+ − 378 font-menu-preferred-resolution
+ − 379 (selected-device))))
428
+ − 380 (and font-menu-this-frame-only-p
+ − 381 (selected-frame))))))
+ − 382
+ − 383 (define-device-method font-menu-load-font)
+ − 384
+ − 385 (defun flush-device-fonts-cache (device)
+ − 386 ;; by Stig@hackvan.com
+ − 387 (let ((elt (assq device device-fonts-cache)))
+ − 388 (and elt
+ − 389 (setq device-fonts-cache (delq elt device-fonts-cache)))))
+ − 390
+ − 391 (add-hook 'delete-device-hook 'flush-device-fonts-cache)
+ − 392
+ − 393 (provide 'font-menu)
+ − 394
+ − 395 ;; font-menu ends here