Mercurial > hg > xemacs-beta
comparison lisp/x-font-menu.el @ 209:41ff10fd062f r20-4b3
Import from CVS: tag r20-4b3
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 10:04:58 +0200 |
| parents | |
| children | 341dac730539 |
comparison
equal
deleted
inserted
replaced
| 208:f427b8ec4379 | 209:41ff10fd062f |
|---|---|
| 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 ;; Copyright (C) 1997 Sun Microsystems | |
| 6 | |
| 7 ;; Author: Jamie Zawinski <jwz@netscape.com> | |
| 8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com> | |
| 9 ;; Mule-ized by: Martin Buchholz | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
| 13 ;; 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 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 21 ;; General Public License for more details. | |
| 22 | |
| 23 ;; 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 ;; Free Software Foundation, 59 Temple Place - Suite 330, | |
| 26 ;; 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: | |
| 127 | |
| 128 ;; #### - implement these... | |
| 129 ;; | |
| 130 ;;; (defvar font-menu-ignore-proportional-fonts nil | |
| 131 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.") | |
| 132 | |
| 133 ;;;###autoload | |
| 134 (defcustom font-menu-ignore-scaled-fonts t | |
| 135 "*If non-nil, then the font menu will try to show only bitmap fonts." | |
| 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.") | |
| 152 | |
| 153 (defvar font-menu-preferred-resolution "*-*" | |
| 154 "Preferred horizontal and vertical font menu resolution (e.g. \"75-75\").") | |
| 155 | |
| 156 (defvar fonts-menu-junk-families | |
| 157 (purecopy | |
| 158 (mapconcat | |
| 159 #'identity | |
| 160 '("cursor" "glyph" "symbol" ; Obvious losers. | |
| 161 "\\`Ax...\\'" ; FrameMaker fonts - there are just way too | |
| 162 ; many of these, and there is a different | |
| 163 ; font family for each font face! Losers. | |
| 164 ; "Axcor" -> "Applix Courier Roman", | |
| 165 ; "Axcob" -> "Applix Courier Bold", etc. | |
| 166 ) | |
| 167 "\\|")) | |
| 168 "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 | |
| 175 (defun hack-font-truename (fn) | |
| 176 "Filter the output of `font-instance-truename' to deal with Japanese fontsets." | |
| 177 (if (string-match "," (font-instance-truename fn)) | |
| 178 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-"))) | |
| 179 (flist (split-string (font-instance-truename fn) ",")) | |
| 180 ret) | |
| 181 (while flist | |
| 182 (if (string-equal fpnt (nth 8 (split-string (car flist) "-"))) | |
| 183 (progn (setq ret (car flist)) (setq flist nil)) | |
| 184 (setq flist (cdr flist)) | |
| 185 )) | |
| 186 ret) | |
| 187 (font-instance-truename fn))) | |
| 188 | |
| 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 | |
| 194 "This is used to filter out font families that can't display ASCII text. | |
| 195 It must be set at run-time.") | |
| 196 | |
| 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 | |
| 208 (defun reset-device-font-menus (&optional device debug) | |
| 209 "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. | |
| 211 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 | |
| 213 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." | |
| 215 ;; by Stig@hackvan.com | |
| 216 ;; #### - this should implement a `menus-only' option, which would | |
| 217 ;; recalculate the menus from the cache w/o having to do list-fonts again. | |
| 218 (message "Getting list of fonts from server... ") | |
| 219 (if (or noninteractive | |
| 220 (not (or device (setq device (selected-device)))) | |
| 221 (not (eq (device-type device) 'x))) | |
| 222 nil | |
| 223 (unless x-font-regexp-ascii | |
| 224 (setq x-font-regexp-ascii (if (featurep 'mule) | |
| 225 (charset-registry 'ascii) | |
| 226 "iso8859-1"))) | |
| 227 (setq font-menu-registry-encoding | |
| 228 (if (featurep 'mule) "*-*" "iso8859-1")) | |
| 229 (let ((case-fold-search t) | |
| 230 family size weight entry monospaced-p | |
| 231 dev-cache cache families sizes weights) | |
| 232 (dolist (name (cond ((null debug) ; debugging kludge | |
| 233 (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)) | |
| 234 ((stringp debug) (split-string debug "\n")) | |
| 235 (t debug))) | |
| 236 (when (and (string-match x-font-regexp-ascii name) | |
| 237 (string-match x-font-regexp name)) | |
| 238 (setq weight (capitalize (match-string 1 name)) | |
| 239 size (string-to-int (match-string 6 name))) | |
| 240 (or (string-match x-font-regexp-foundry-and-family name) | |
| 241 (error "internal error")) | |
| 242 (setq family (capitalize (match-string 1 name))) | |
| 243 (or (string-match x-font-regexp-spacing name) | |
| 244 (error "internal error")) | |
| 245 (setq monospaced-p (string= "m" (match-string 1 name))) | |
| 246 (unless (string-match fonts-menu-junk-families family) | |
| 247 (setq entry (or (vassoc family cache) | |
| 248 (car (setq cache | |
| 249 (cons (vector family nil nil t) | |
| 250 cache))))) | |
| 251 (or (member family families) (push family families)) | |
| 252 (or (member weight weights) (push weight weights)) | |
| 253 (or (member size sizes) (push size sizes)) | |
| 254 (or (member weight (aref entry 1)) (push weight (aref entry 1))) | |
| 255 (or (member size (aref entry 2)) (push size (aref entry 2))) | |
| 256 (aset entry 3 (and (aref entry 3) monospaced-p))))) | |
| 257 ;; | |
| 258 ;; Hack scalable fonts. | |
| 259 ;; Some fonts come only in scalable versions (the only size is 0) | |
| 260 ;; and some fonts come in both scalable and non-scalable versions | |
| 261 ;; (one size is 0). If there are any scalable fonts at all, make | |
| 262 ;; sure that the union of all point sizes contains at least some | |
| 263 ;; common sizes - it's possible that some sensible sizes might end | |
| 264 ;; up not getting mentioned explicitly. | |
| 265 ;; | |
| 266 (if (member 0 sizes) | |
| 267 (let ((common '(60 80 100 120 140 160 180 240))) | |
| 268 (while common | |
| 269 (or;;(member (car common) sizes) ; not enough slack | |
| 270 (let ((rest sizes) | |
| 271 (done nil)) | |
| 272 (while (and (not done) rest) | |
| 273 (if (and (> (car common) (- (car rest) 5)) | |
| 274 (< (car common) (+ (car rest) 5))) | |
| 275 (setq done t)) | |
| 276 (setq rest (cdr rest))) | |
| 277 done) | |
| 278 (setq sizes (cons (car common) sizes))) | |
| 279 (setq common (cdr common))) | |
| 280 (setq sizes (delq 0 sizes)))) | |
| 281 | |
| 282 (setq families (sort families 'string-lessp) | |
| 283 weights (sort weights 'string-lessp) | |
| 284 sizes (sort sizes '<)) | |
| 285 | |
| 286 (dolist (entry cache) | |
| 287 (aset entry 1 (sort (aref entry 1) 'string-lessp)) | |
| 288 (aset entry 2 (sort (aref entry 2) '<))) | |
| 289 | |
| 290 (message "Getting list of fonts from server... done.") | |
| 291 | |
| 292 (setq dev-cache (assq device device-fonts-cache)) | |
| 293 (or dev-cache | |
| 294 (setq dev-cache (car (push (list device) device-fonts-cache)))) | |
| 295 (setcdr | |
| 296 dev-cache | |
| 297 (vector | |
| 298 cache | |
| 299 (mapcar (lambda (x) | |
| 300 (vector x | |
| 301 (list 'font-menu-set-font x nil nil) | |
| 302 ':style 'radio ':active nil ':selected nil)) | |
| 303 families) | |
| 304 (mapcar (lambda (x) | |
| 305 (vector (if (/= 0 (% x 10)) | |
| 306 ;; works with no LISP_FLOAT_TYPE | |
| 307 (concat (int-to-string (/ x 10)) "." | |
| 308 (int-to-string (% x 10))) | |
| 309 (int-to-string (/ x 10))) | |
| 310 (list 'font-menu-set-font nil nil x) | |
| 311 ':style 'radio ':active nil ':selected nil)) | |
| 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 | |
| 320 ;; Extract font information from a face. We examine both the | |
| 321 ;; user-specified font name and the canonical (`true') font name. | |
| 322 ;; These can appear to have totally different properties. | |
| 323 ;; For examples, see the prolog above. | |
| 324 | |
| 325 ;; We use the user-specified one if possible, else use the truename. | |
| 326 ;; If the user didn't specify one (with "-dt-*-*", for example) | |
| 327 ;; get the truename and use the possibly suboptimal data from that. | |
| 328 (defun* font-menu-font-data (face dcache) | |
| 329 (let* ((case-fold-search t) | |
| 330 (domain (if font-menu-this-frame-only-p | |
| 331 (selected-frame) | |
| 332 (selected-device))) | |
| 333 (name (font-instance-name (face-font-instance face domain))) | |
| 334 (truename (font-instance-truename | |
| 335 (face-font-instance face domain | |
| 336 (if (featurep 'mule) 'ascii)))) | |
| 337 family size weight entry slant) | |
| 338 (when (string-match x-font-regexp-foundry-and-family name) | |
| 339 (setq family (capitalize (match-string 1 name))) | |
| 340 (setq entry (vassoc family (aref dcache 0)))) | |
| 341 (when (and (null entry) | |
| 342 (string-match x-font-regexp-foundry-and-family truename)) | |
| 343 (setq family (capitalize (match-string 1 truename))) | |
| 344 (setq entry (vassoc family (aref dcache 0)))) | |
| 345 (when (null entry) | |
| 346 (return-from font-menu-font-data (make-vector 5 nil))) | |
| 347 | |
| 348 (when (string-match x-font-regexp name) | |
| 349 (setq weight (capitalize (match-string 1 name))) | |
| 350 (setq size (string-to-int (match-string 6 name)))) | |
| 351 | |
| 352 (when (string-match x-font-regexp truename) | |
| 353 (when (not (member weight (aref entry 1))) | |
| 354 (setq weight (capitalize (match-string 1 truename)))) | |
| 355 (when (not (member size (aref entry 2))) | |
| 356 (setq size (string-to-int (match-string 6 truename)))) | |
| 357 (setq slant (capitalize (match-string 2 truename)))) | |
| 358 | |
| 359 (vector entry family size weight slant))) | |
| 360 | |
| 361 ;;;###autoload | |
| 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 (unless from-family | |
| 471 (signal 'error '("couldn't parse font name for default face"))) | |
| 472 (setq new-default-face-font | |
| 473 (font-menu-load-font (or family from-family) | |
| 474 (or weight from-weight) | |
| 475 (or size from-size) | |
| 476 from-slant | |
| 477 font-menu-preferred-resolution)) | |
| 478 (dolist (face (delq 'default (face-list))) | |
| 479 (when (face-font-instance face) | |
| 480 (message "Changing font of `%s'..." face) | |
| 481 (condition-case c | |
| 482 (font-menu-change-face face | |
| 483 from-family from-weight from-size | |
| 484 family weight size) | |
| 485 (error | |
| 486 (display-error c nil) | |
| 487 (sit-for 1))))) | |
| 488 ;; Set the default face's font after hacking the other faces, so that | |
| 489 ;; the frame size doesn't change until we are all done. | |
| 490 | |
| 491 ;;; WMP - we need to honor font-menu-this-frame-only-p here! | |
| 492 (set-face-font 'default new-default-face-font | |
| 493 (and font-menu-this-frame-only-p (selected-frame))) | |
| 494 (message "Font %s" (face-font-name 'default)))) | |
| 495 | |
| 496 | |
| 497 (defun font-menu-change-face (face | |
| 498 from-family from-weight from-size | |
| 499 to-family to-weight to-size) | |
| 500 (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face))) | |
| 501 (let* ((dcache (device-fonts-cache)) | |
| 502 (font-data (font-menu-font-data face dcache)) | |
| 503 (face-family (aref font-data 1)) | |
| 504 (face-size (aref font-data 2)) | |
| 505 (face-weight (aref font-data 3)) | |
| 506 (face-slant (aref font-data 4))) | |
| 507 | |
| 508 (or face-family | |
| 509 (signal 'error (list "couldn't parse font name for face" face))) | |
| 510 | |
| 511 ;; If this face matches the old default face in the attribute we | |
| 512 ;; are changing, then change it to the new attribute along that | |
| 513 ;; dimension. Also, the face must have its own global attribute. | |
| 514 ;; If its value is inherited, we don't touch it. If any of this | |
| 515 ;; is not true, we leave it alone. | |
| 516 (when (and (face-font face 'global) | |
| 517 (cond | |
| 518 (to-family (string-equal face-family from-family)) | |
| 519 (to-weight (string-equal face-weight from-weight)) | |
| 520 (to-size (= face-size from-size)))) | |
| 521 (set-face-font face | |
| 522 (font-menu-load-font (or to-family face-family) | |
| 523 (or to-weight face-weight) | |
| 524 (or to-size face-size) | |
| 525 face-slant | |
| 526 font-menu-preferred-resolution) | |
| 527 (and font-menu-this-frame-only-p | |
| 528 (selected-frame)))))) | |
| 529 | |
| 530 (defun font-menu-load-font (family weight size slant resolution) | |
| 531 "Try to load a font with the requested properties. | |
| 532 The weight, slant and resolution are only hints." | |
| 533 (when (integerp size) (setq size (int-to-string size))) | |
| 534 (let (font) | |
| 535 (catch 'got-font | |
| 536 (dolist (weight (list weight "*")) | |
| 537 (dolist (slant | |
| 538 (cond ((string-equal slant "O") '("O" "I" "*")) | |
| 539 ((string-equal slant "I") '("I" "O" "*")) | |
| 540 ((string-equal slant "*") '("*")) | |
| 541 (t (list slant "*")))) | |
| 542 (dolist (resolution | |
| 543 (if (string-equal resolution "*-*") | |
| 544 (list resolution) | |
| 545 (list resolution "*-*"))) | |
| 546 (when (setq font | |
| 547 (make-font-instance | |
| 548 (concat "-*-" family "-" weight "-" slant "-*-*-*-" | |
| 549 size "-" resolution "-*-*-" | |
| 550 font-menu-registry-encoding) | |
| 551 nil t)) | |
| 552 (throw 'got-font font)))))))) | |
| 553 | |
| 554 (defun flush-device-fonts-cache (device) | |
| 555 ;; by Stig@hackvan.com | |
| 556 (let ((elt (assq device device-fonts-cache))) | |
| 557 (and elt | |
| 558 (setq device-fonts-cache (delq elt device-fonts-cache))))) | |
| 559 | |
| 560 (add-hook 'delete-device-hook 'flush-device-fonts-cache) | |
| 561 | |
| 562 (provide 'x-font-menu) | |
| 563 | |
| 564 ;;; x-font-menu.el ends here |