git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/x-font-menu.el

   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 \f
 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