Mercurial > hg > xemacs-beta
comparison lisp/font-menu.el @ 428:3ecd8885ac67 r21-2-22
Import from CVS: tag r21-2-22
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 11:28:15 +0200 |
| parents | |
| children | 8de8e3f6228a |
comparison
equal
deleted
inserted
replaced
| 427:0a0253eac470 | 428:3ecd8885ac67 |
|---|---|
| 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 | |
| 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. | |
| 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 ;;; | |
| 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 ;;; `mswindows-font-regexp' and `mswindows-font-regexp-foundry-and-family' defined in | |
| 69 ;;; mswindows-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 ;;;###autoload | |
| 127 (defcustom font-menu-ignore-scaled-fonts nil | |
| 128 "*If non-nil, then the font menu will try to show only bitmap fonts." | |
| 129 :type 'boolean | |
| 130 :group 'font-menu) | |
| 131 | |
| 132 ;;;###autoload | |
| 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." | |
| 136 :type 'boolean | |
| 137 :group 'font-menu) | |
| 138 | |
| 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 | |
| 143 submenus." | |
| 144 :group 'font-menu | |
| 145 :type '(choice (const :tag "no submenus" nil) | |
| 146 (integer))) | |
| 147 | |
| 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." | |
| 157 :group 'font-menu | |
| 158 :type '(choice (string :tag "Format string") | |
| 159 (function))) | |
| 160 | |
| 161 (defvar font-menu-preferred-resolution | |
| 162 (make-specifier-and-init 'generic '((global ((mswindows) . ":") | |
| 163 ((x) . "*-*"))) t) | |
| 164 "Preferred horizontal and vertical font menu resolution (e.g. \"75:75\").") | |
| 165 | |
| 166 (defvar font-menu-size-scaling | |
| 167 (make-specifier-and-init 'integer '((global ((mswindows) . 1) | |
| 168 ((x) . 10))) t) | |
| 169 "Scale factor used in defining font sizes.") | |
| 170 | |
| 171 (defun vassoc (key valist) | |
| 172 "Search VALIST for a vector whose first element is equal to KEY. | |
| 173 See also `assoc'." | |
| 174 ;; by Stig@hackvan.com | |
| 175 (let (el) | |
| 176 (catch 'done | |
| 177 (while (setq el (pop valist)) | |
| 178 (and (equal key (aref el 0)) | |
| 179 (throw 'done el)))))) | |
| 180 | |
| 181 ;; only call XListFonts (and parse) once per device. | |
| 182 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...) | |
| 183 (defvar device-fonts-cache nil) | |
| 184 | |
| 185 (defsubst device-fonts-cache () | |
| 186 (or (cdr (assq (selected-device) device-fonts-cache)) | |
| 187 (and (reset-device-font-menus (selected-device)) | |
| 188 (cdr (assq (selected-device) device-fonts-cache))))) | |
| 189 | |
| 190 ;;;###autoload | |
| 191 (fset 'install-font-menus 'reset-device-font-menus) | |
| 192 (make-obsolete 'install-font-menus 'reset-device-font-menus) | |
| 193 | |
| 194 ;;;###autoload | |
| 195 (defun reset-device-font-menus (&optional device debug) | |
| 196 "Generates the `Font', `Size', and `Weight' submenus for the Options menu. | |
| 197 This is run the first time that a font-menu is needed for each device. | |
| 198 If you don't like the lazy invocation of this function, you can add it to | |
| 199 `create-device-hook' and that will make the font menus respond more quickly | |
| 200 when they are selected for the first time. If you add fonts to your system, | |
| 201 or if you change your font path, you can call this to re-initialize the menus." | |
| 202 (message "Getting list of fonts from server... ") | |
| 203 (if (or noninteractive | |
| 204 (not (or device (setq device (selected-device))))) | |
| 205 nil | |
| 206 (call-device-method 'reset-device-font-menus device device debug) | |
| 207 (message "Getting list of fonts from server... done."))) | |
| 208 | |
| 209 (defun font-menu-split-long-menu (menu) | |
| 210 "Split MENU according to `font-menu-max-items'." | |
| 211 (let ((len (length menu))) | |
| 212 (if (or (null font-menu-max-items) | |
| 213 (null (featurep 'lisp-float-type)) | |
| 214 (<= len font-menu-max-items)) | |
| 215 menu | |
| 216 ;; Submenu is max 2 entries longer than menu, never shorter, number of | |
| 217 ;; entries in submenus differ by at most one (with longer submenus first) | |
| 218 (let* ((outer (floor (sqrt len))) | |
| 219 (inner (/ len outer)) | |
| 220 (rest (% len outer)) | |
| 221 (result nil)) | |
| 222 (setq menu (reverse menu)) | |
| 223 (while menu | |
| 224 (let ((in inner) | |
| 225 (sub nil) | |
| 226 (to (car menu))) | |
| 227 (while (> in 0) | |
| 228 (setq in (1- in) | |
| 229 sub (cons (car menu) sub) | |
| 230 menu (cdr menu))) | |
| 231 (setq result | |
| 232 (cons (cons (if (stringp font-menu-submenu-name-format) | |
| 233 (format font-menu-submenu-name-format | |
| 234 (aref (car sub) 0) (aref to 0)) | |
| 235 (funcall font-menu-submenu-name-format | |
| 236 (aref (car sub) 0) (aref to 0))) | |
| 237 sub) | |
| 238 result) | |
| 239 rest (1+ rest)) | |
| 240 (if (= rest outer) (setq inner (1+ inner))))) | |
| 241 result)))) | |
| 242 | |
| 243 ;;;###autoload | |
| 244 (defun font-menu-family-constructor (ignored) | |
| 245 (catch 'menu | |
| 246 (unless (console-on-window-system-p) | |
| 247 (throw 'menu '(["Cannot parse current font" ding nil]))) | |
| 248 (let* ((dcache (device-fonts-cache)) | |
| 249 (font-data (font-menu-font-data 'default dcache)) | |
| 250 (entry (aref font-data 0)) | |
| 251 (family (aref font-data 1)) | |
| 252 (size (aref font-data 2)) | |
| 253 (weight (aref font-data 3)) | |
| 254 f) | |
| 255 (unless family | |
| 256 (throw 'menu '(["Cannot parse current font" ding nil]))) | |
| 257 ;; Items on the Font menu are enabled iff that font exists in | |
| 258 ;; the same size and weight as the current font (scalable fonts | |
| 259 ;; exist in every size). Only the current font is marked as | |
| 260 ;; selected. | |
| 261 (font-menu-split-long-menu | |
| 262 (mapcar | |
| 263 (lambda (item) | |
| 264 (setq f (aref item 0) | |
| 265 entry (vassoc f (aref dcache 0))) | |
| 266 (if (and (or (member weight (aref entry 1)) | |
| 267 ;; mswindows often allows any weight | |
| 268 (member "" (aref entry 1))) | |
| 269 (or (member size (aref entry 2)) | |
| 270 (and (not font-menu-ignore-scaled-fonts) | |
| 271 (member 0 (aref entry 2))))) | |
| 272 (enable-menu-item item) | |
| 273 (disable-menu-item item)) | |
| 274 (if (string-equal family f) | |
| 275 (select-toggle-menu-item item) | |
| 276 (deselect-toggle-menu-item item)) | |
| 277 item) | |
| 278 (aref dcache 1)))))) | |
| 279 | |
| 280 (define-device-method* font-menu-font-data) | |
| 281 | |
| 282 ;;;###autoload | |
| 283 (defun font-menu-size-constructor (ignored) | |
| 284 (catch 'menu | |
| 285 (unless (console-on-window-system-p) | |
| 286 (throw 'menu '(["Cannot parse current font" ding nil]))) | |
| 287 (let* ((dcache (device-fonts-cache)) | |
| 288 (font-data (font-menu-font-data 'default dcache)) | |
| 289 (entry (aref font-data 0)) | |
| 290 (family (aref font-data 1)) | |
| 291 (size (aref font-data 2)) | |
| 292 ;;(weight (aref font-data 3)) | |
| 293 s) | |
| 294 (unless family | |
| 295 (throw 'menu '(["Cannot parse current font" ding nil]))) | |
| 296 ;; Items on the Size menu are enabled iff current font has | |
| 297 ;; that size. Only the size of the current font is selected. | |
| 298 ;; (If the current font comes in size 0, it is scalable, and | |
| 299 ;; thus has every size.) | |
| 300 (mapcar | |
| 301 (lambda (item) | |
| 302 (setq s (nth 3 (aref item 1))) | |
| 303 (if (or (member s (aref entry 2)) | |
| 304 (and (not font-menu-ignore-scaled-fonts) | |
| 305 (member 0 (aref entry 2)))) | |
| 306 (enable-menu-item item) | |
| 307 (disable-menu-item item)) | |
| 308 (if (eq size s) | |
| 309 (select-toggle-menu-item item) | |
| 310 (deselect-toggle-menu-item item)) | |
| 311 item) | |
| 312 (aref dcache 2))))) | |
| 313 | |
| 314 ;;;###autoload | |
| 315 (defun font-menu-weight-constructor (ignored) | |
| 316 (catch 'menu | |
| 317 (unless (console-on-window-system-p) | |
| 318 (throw 'menu '(["Cannot parse current font" ding nil]))) | |
| 319 (let* ((dcache (device-fonts-cache)) | |
| 320 (font-data (font-menu-font-data 'default dcache)) | |
| 321 (entry (aref font-data 0)) | |
| 322 (family (aref font-data 1)) | |
| 323 ;;(size (aref font-data 2)) | |
| 324 (weight (aref font-data 3)) | |
| 325 w) | |
| 326 (unless family | |
| 327 (throw 'menu '(["Cannot parse current font" ding nil]))) | |
| 328 ;; Items on the Weight menu are enabled iff current font | |
| 329 ;; has that weight. Only the weight of the current font | |
| 330 ;; is selected. | |
| 331 (mapcar | |
| 332 (lambda (item) | |
| 333 (setq w (aref item 0)) | |
| 334 (if (member w (aref entry 1)) | |
| 335 (enable-menu-item item) | |
| 336 (disable-menu-item item)) | |
| 337 (if (string-equal weight w) | |
| 338 (select-toggle-menu-item item) | |
| 339 (deselect-toggle-menu-item item)) | |
| 340 item) | |
| 341 (aref dcache 3))))) | |
| 342 | |
| 343 | |
| 344 ;;; Changing font sizes | |
| 345 | |
| 346 (defun font-menu-set-font (family weight size) | |
| 347 ;; This is what gets run when an item is selected from any of the three | |
| 348 ;; fonts menus. It needs to be rather clever. | |
| 349 ;; (size is measured in 10ths of points.) | |
| 350 (let* ((dcache (device-fonts-cache)) | |
| 351 (font-data (font-menu-font-data 'default dcache)) | |
| 352 (from-family (aref font-data 1)) | |
| 353 (from-size (aref font-data 2)) | |
| 354 (from-weight (aref font-data 3)) | |
| 355 (from-slant (aref font-data 4)) | |
| 356 (face-list-to-change (delq 'default (face-list))) | |
| 357 new-default-face-font | |
| 358 new-props) | |
| 359 (unless from-family | |
| 360 (signal 'error '("couldn't parse font name for default face"))) | |
| 361 (when weight | |
| 362 (signal 'error '("Setting weight currently not supported"))) | |
| 363 (setq new-default-face-font | |
| 364 (font-menu-load-font | |
| 365 (or family from-family) | |
| 366 (or weight from-weight) | |
| 367 (or size from-size) | |
| 368 from-slant | |
| 369 (specifier-instance | |
| 370 font-menu-preferred-resolution (selected-device)))) | |
| 371 ;; This is such a gross hack. The border-glyph face under | |
| 372 ;; mswindows is in a symbol font. Thus it will not appear in the | |
| 373 ;; cache - being a junk family. What we should do is change the | |
| 374 ;; size but not the family, but this is more work than I care to | |
| 375 ;; invest at the moment. | |
| 376 (when (eq (device-type) 'mswindows) | |
| 377 (setq face-list-to-change | |
| 378 (delq 'border-glyph face-list-to-change))) | |
| 379 (dolist (face face-list-to-change) | |
| 380 (when (face-font-instance face) | |
| 381 (message "Changing font of `%s'..." face) | |
| 382 (condition-case c | |
| 383 (font-menu-change-face face | |
| 384 from-family from-weight from-size | |
| 385 family weight size) | |
| 386 (error | |
| 387 (display-error c nil) | |
| 388 (sit-for 1))))) | |
| 389 ;; Set the default face's font after hacking the other faces, so that | |
| 390 ;; the frame size doesn't change until we are all done. | |
| 391 | |
| 392 ;; If we need to be frame local we do the changes ourselves. | |
| 393 (if font-menu-this-frame-only-p | |
| 394 ;;; WMP - we need to honor font-menu-this-frame-only-p here! | |
| 395 (set-face-font 'default new-default-face-font | |
| 396 (and font-menu-this-frame-only-p (selected-frame))) | |
| 397 ;; OK Let Customize do it. | |
| 398 (custom-set-face-update-spec 'default | |
| 399 (list (list 'type (device-type))) | |
| 400 (list :family family | |
| 401 :size (concat | |
| 402 (int-to-string | |
| 403 (/ (or size from-size) | |
| 404 (specifier-instance font-menu-size-scaling | |
| 405 (selected-device)))) | |
| 406 "pt"))) | |
| 407 (message "Font %s" (face-font-name 'default))))) | |
| 408 | |
| 409 | |
| 410 (defun font-menu-change-face (face | |
| 411 from-family from-weight from-size | |
| 412 to-family to-weight to-size) | |
| 413 (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face))) | |
| 414 (let* ((dcache (device-fonts-cache)) | |
| 415 (font-data (font-menu-font-data face dcache)) | |
| 416 (face-family (aref font-data 1)) | |
| 417 (face-size (aref font-data 2)) | |
| 418 (face-weight (aref font-data 3)) | |
| 419 (face-slant (aref font-data 4))) | |
| 420 | |
| 421 (or face-family | |
| 422 (signal 'error (list "couldn't parse font name for face" face))) | |
| 423 | |
| 424 ;; If this face matches the old default face in the attribute we | |
| 425 ;; are changing, then change it to the new attribute along that | |
| 426 ;; dimension. Also, the face must have its own global attribute. | |
| 427 ;; If its value is inherited, we don't touch it. If any of this | |
| 428 ;; is not true, we leave it alone. | |
| 429 (when (and (face-font face 'global) | |
| 430 (cond | |
| 431 (to-family (string-equal face-family from-family)) | |
| 432 (to-weight (string-equal face-weight from-weight)) | |
| 433 (to-size (= face-size from-size)))) | |
| 434 (set-face-font face | |
| 435 (font-menu-load-font (or to-family face-family) | |
| 436 (or to-weight face-weight) | |
| 437 (or to-size face-size) | |
| 438 face-slant | |
| 439 (specifier-instance | |
| 440 font-menu-preferred-resolution | |
| 441 (selected-device))) | |
| 442 (and font-menu-this-frame-only-p | |
| 443 (selected-frame)))))) | |
| 444 | |
| 445 (define-device-method font-menu-load-font) | |
| 446 | |
| 447 (defun flush-device-fonts-cache (device) | |
| 448 ;; by Stig@hackvan.com | |
| 449 (let ((elt (assq device device-fonts-cache))) | |
| 450 (and elt | |
| 451 (setq device-fonts-cache (delq elt device-fonts-cache))))) | |
| 452 | |
| 453 (add-hook 'delete-device-hook 'flush-device-fonts-cache) | |
| 454 | |
| 455 (provide 'font-menu) | |
| 456 | |
| 457 ;; font-menu ends here |