home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / x11 / x-font-menu.el < prev    next >
Encoding:
Text File  |  1995-06-29  |  23.7 KB  |  628 lines
  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. ;;; parameters 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.     (set-face-font 'default new-default-face-font)
  468.     (message "Font %s" (face-font-name 'default))))
  469.  
  470.  
  471. (defun font-menu-change-face (face
  472.                   from-family from-weight from-size
  473.                   to-family   to-weight   to-size)
  474.   (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
  475.   (let* ((font (face-font-instance face))
  476.      (name (hack-font-truename font))
  477.      (case-fold-search t)
  478.      face-family
  479.      face-weight
  480.      face-size)
  481.     ;; First, parse out the face's font.
  482.     (or (string-match x-font-regexp-foundry-and-family name)
  483.     (signal 'error (list "couldn't parse font name" name)))
  484.     (setq face-family (capitalize (match-string 1 name)))
  485.     (or (string-match x-font-regexp name)
  486.     (signal 'error (list "couldn't parse font name" name)))
  487.     (setq face-weight (match-string 1 name))
  488.     (setq face-size (match-string 6 name))
  489.  
  490.     ;; If this face matches the old default face in the attribute we
  491.     ;; are changing, then change it to the new attribute along that
  492.     ;; dimension.  Also, the face must have its own global attribute.
  493.     ;; If its value is inherited, we don't touch it.  If any of this
  494.     ;; is not true, we leave it alone.
  495.     (if (and (face-font face 'global)
  496.          (cond 
  497.           (to-family (equal face-family from-family))
  498.           (to-weight (equal face-weight from-weight))
  499.           (to-size   (equal face-size from-size))))
  500.     (set-face-font face
  501.                (font-menu-load-font (or to-family face-family)
  502.                         (or to-weight face-weight)
  503.                         (or to-size   face-size)
  504.                         name)
  505.                (and font-menu-this-frame-only-p
  506.                 (selected-frame)))
  507.       nil)))
  508.  
  509.  
  510. (defun font-menu-load-font (family weight size from-font)
  511.   (and (numberp size) (setq size (int-to-string size)))
  512.   (let ((case-fold-search t)
  513.     slant other-slant
  514.     registry encoding resx resy)
  515.     (or (string-match x-font-regexp-registry-and-encoding from-font)
  516.     (signal 'error (list "couldn't parse font name" from-font)))
  517.     (setq registry (match-string 1 from-font)
  518.       encoding (match-string 2 from-font))
  519.  
  520.     (or (string-match x-font-regexp from-font)
  521.     (signal 'error (list "couldn't parse font name" from-font)))
  522.     (setq slant (capitalize (match-string 2 from-font))
  523.       resx  (match-string 7 from-font)
  524.       resy  (match-string 8 from-font))
  525.     (cond ((equal slant "O") (setq other-slant "I")) ; oh, bite me.
  526.       ((equal slant "I") (setq other-slant "O"))
  527.       (t (setq other-slant nil)))
  528.     ;;
  529.     ;; Remember these values for the first font we switch away from
  530.     ;; (the original default font).
  531.     ;;
  532.     (or font-menu-preferred-resolution
  533.     (setq font-menu-preferred-resolution (cons resx resy)))
  534.     (or font-menu-preferred-registry
  535.     (setq font-menu-preferred-registry (cons registry encoding)))
  536.     ;;
  537.     ;; Now we know all the interesting parameters of the font we want.
  538.     ;; Let's see what we can actually *get*.
  539.     ;;
  540.     (or ;; First try the default resolution, registry, and encoding.
  541.         (make-font-instance
  542.      (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
  543.          "-" (car font-menu-preferred-resolution)
  544.          "-" (cdr font-menu-preferred-resolution)
  545.          "-*-*-"
  546.          (car font-menu-preferred-registry) "-"
  547.          (cdr font-menu-preferred-registry))
  548.      nil t)
  549.     ;; Then try that in the other slant.
  550.     (and other-slant
  551.          (make-font-instance
  552.           (concat "-*-" family "-" weight "-" other-slant
  553.               "-*-*-*-" size
  554.               "-" (car font-menu-preferred-resolution)
  555.               "-" (cdr font-menu-preferred-resolution)
  556.               "-*-*-"
  557.               (car font-menu-preferred-registry) "-"
  558.               (cdr font-menu-preferred-registry))
  559.           nil t))
  560.     ;; Then try the default resolution and registry, any encoding.
  561.     (make-font-instance
  562.      (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
  563.          "-" (car font-menu-preferred-resolution)
  564.          "-" (cdr font-menu-preferred-resolution)
  565.          "-*-*-"
  566.          (car font-menu-preferred-registry) "-*")
  567.      nil t)
  568.     ;; Then try that in the other slant.
  569.     (and other-slant
  570.          (make-font-instance
  571.           (concat "-*-" family "-" weight "-" other-slant
  572.               "-*-*-*-" size
  573.               "-" (car font-menu-preferred-resolution)
  574.               "-" (cdr font-menu-preferred-resolution)
  575.               "-*-*-"
  576.               (car font-menu-preferred-registry) "-*")
  577.           nil t))
  578.     ;; Then try the default registry and encoding, any resolution.
  579.     (make-font-instance
  580.      (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
  581.          "-*-*-*-*-"
  582.          (car font-menu-preferred-registry) "-"
  583.          (cdr font-menu-preferred-registry))
  584.      nil t)
  585.     ;; Then try that in the other slant.
  586.     (and other-slant
  587.          (make-font-instance
  588.           (concat "-*-" family "-" weight "-" other-slant
  589.               "-*-*-*-" size
  590.               "-*-*-*-*-"
  591.               (car font-menu-preferred-registry) "-"
  592.               (cdr font-menu-preferred-registry))
  593.           nil t))
  594.     ;; Then try the default registry, any encoding or resolution.
  595.     (make-font-instance
  596.      (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
  597.          "-*-*-*-*-"
  598.          (car font-menu-preferred-registry) "-*")
  599.      nil t)
  600.     ;; Then try that in the other slant.
  601.     (and other-slant
  602.          (make-font-instance
  603.           (concat "-*-" family "-" weight "-" slant "-*-*-*-"
  604.               size "-*-*-*-*-"
  605.               (car font-menu-preferred-registry) "-*")
  606.           nil t))
  607.     ;; Then try anything in the same slant, and error if it fails...
  608.     (and other-slant
  609.          (make-font-instance
  610.           (concat "-*-" family "-" weight "-" slant "-*-*-*-"
  611.               size "-*-*-*-*-*-*")))
  612.     (make-font-instance
  613.      (concat "-*-" family "-" weight "-" (or other-slant slant)
  614.          "-*-*-*-" size "-*-*-*-*-*-*"))
  615.     )))
  616.  
  617. (defun flush-device-fonts-cache (device)
  618.   ;; by Stig@hackvan.com
  619.   (let ((elt (assq device device-fonts-cache)))
  620.     (and elt
  621.      (setq device-fonts-cache (delq elt device-fonts-cache)))))
  622.  
  623. (add-hook 'delete-device-hook 'flush-device-fonts-cache)
  624.  
  625. (provide 'x-font-menu)
  626.  
  627. ;;; x-font-menu.el ends here
  628.