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