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

   1 ;; font-menu.el --- Managing menus of fonts.
   2
   3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
   5 ;; Copyright (C) 1997 Sun Microsystems
   6
   7 ;; Adapted from x-font-menu.el by Andy Piper <andy@xemacs.org>
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;; This file contains the device-nospecific font menu stuff
  27
  28 ;;; Commentary:
  29 ;;;
  30 ;;; Creates three menus, "Font", "Size", and "Weight", and puts them on the
  31 ;;; "Options" menu.  The contents of these menus are the superset of those
  32 ;;; properties available on any fonts, but only the intersection of the three
  33 ;;; sets is selectable at one time.
  34 ;;;
  35 ;;; Known Problems:
  36 ;;; ===============
  37 ;;; Items on the Font menu are selectable if and only if that font exists in
  38 ;;; the same size and weight as the current font.  This means that some fonts
  39 ;;; are simply not reachable from some other fonts - if only one font comes
  40 ;;; in only one point size (like "Nil", which comes only in 2), you will never
  41 ;;; be able to select it.  It would be better if the items on the Fonts menu
  42 ;;; were always selectable, and selecting them would set the size to be the
  43 ;;; closest size to the current font's size.
  44 ;;;
  45 ;;; This attempts to change all other faces in an analagous way to the change
  46 ;;; that was made to the default face; if it can't, it will skip over the face.
  47 ;;; However, this could leave incongruous font sizes around, which may cause
  48 ;;; some nonreversibility problems if further changes are made.  Perhaps it
  49 ;;; should remember the initial fonts of all faces, and derive all subsequent
  50 ;;; fonts from that initial state.
  51 ;;;
  52 ;;; xfontsel(1) is a lot more flexible (but probably harder to understand).
  53 ;;;
  54 ;;; The code to construct menus from all of the x11 fonts available from the
  55 ;;; server is autoloaded and executed the very first time that one of the Font
  56 ;;; menus is selected on each device.  That is, if XEmacs has frames on two
  57 ;;; different devices, then separate font menu information will be maintained
  58 ;;; for each X display.  If the font path changes after emacs has already
  59 ;;; asked the X server on a particular display for its list of fonts, this
  60 ;;; won't notice.  Also, the first time that a font menu is posted on each
  61 ;;; display will entail a lengthy delay, but that's better than slowing down
  62 ;;; XEmacs startup.  At any time (i.e.: after a font-path change or
  63 ;;; immediately after device creation), you can call
  64 ;;; `reset-device-font-menus' to rebuild the menus from all currently
  65 ;;; available fonts.
  66 ;;;
  67 ;;; There is knowledge here about the regexp match numbers in
  68 ;;; `mswindows-font-regexp' and `mswindows-font-regexp-foundry-and-family' defined in
  69 ;;; mswindows-faces.el.
  70 ;;;
  71 ;;; There are at least three kinds of fonts under X11r5:
  72 ;;;
  73 ;;; - bitmap fonts, which can be assumed to look as good as possible;
  74 ;;; - bitmap fonts which have been (or can be) automatically scaled to
  75 ;;;   a new size, and which almost always look awful;
  76 ;;; - and true outline fonts, which should look ok at any size, but in
  77 ;;;   practice (on at least some systems) look awful at any size, and
  78 ;;;   even in theory are unlikely ever to look as good as non-scaled
  79 ;;;   bitmap fonts.
  80 ;;;
  81 ;;; It would be nice to get this code to look for non-scaled bitmap fonts
  82 ;;; first, then outline fonts, then scaled bitmap fonts as a last resort.
  83 ;;; But it's not clear to me how to tell them apart based on their truenames
  84 ;;; and/or the result of XListFonts().  I welcome any and all explanations
  85 ;;; of the subtleties involved...
  86 ;;;
  87 ;;;
  88 ;;; If You Think You'Re Seeing A Bug:
  89 ;;; =================================
  90 ;;; When reporting problems, send the following information:
  91 ;;;
  92 ;;; - Exactly what behavior you're seeing;
  93 ;;; - The output of the `xlsfonts' program;
  94 ;;; - The value of the variable `device-fonts-cache';
  95 ;;; - The values of the following expressions, both before and after
  96 ;;;   making a selection from any of the fonts-related menus:
  97 ;;;     (face-font 'default)
  98 ;;;     (font-truename   (face-font 'default))
  99 ;;;     (font-properties (face-font 'default))
 100 ;;; - The values of the following variables after making a selection:
 101 ;;;     font-menu-preferred-resolution
 102 ;;;     font-menu-registry-encoding
 103 ;;;
 104 ;;; There is a common misconception that "*-courier-medium-r-*-11-*", also
 105 ;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1",
 106 ;;; is an 11-point font.  It is not -- it is an 11-pixel font at 100dpi,
 107 ;;; which is an 8-point font (the number after -11- is the size in tenths
 108 ;;; of points).  So if you expect to be seeing an "11" entry in the "Size"
 109 ;;; menu and are not, this may be why.
 110 ;;;
 111 ;;; In the real world (aka Solaris), one has to deal with fonts that
 112 ;;; appear to be medium-i but are really light-r, and fonts that
 113 ;;; resolve to different resolutions depending on the charset:
 114 ;;;
 115 ;;; (font-instance-truename
 116 ;;;  (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*"))
 117 ;;; ==>
 118 ;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0"
 119 ;;;
 120 ;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*")
 121 ;;; ==>
 122 ;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1"
 123 ;;;  "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0"
 124 ;;;  "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0")
 125
 126 ;;;###autoload
 127 (defcustom font-menu-ignore-scaled-fonts nil
 128   "*If non-nil, then the font menu will try to show only bitmap fonts."
 129   :type 'boolean
 130   :group 'font-menu)
 131
 132 ;;;###autoload
 133 (defcustom font-menu-this-frame-only-p nil
 134   "*If non-nil, then changing the default font from the font menu will only
 135 affect one frame instead of all frames."
 136   :type 'boolean
 137   :group 'font-menu)
 138
 139 (defcustom font-menu-max-items 25
 140   "*Maximum number of items in the font menu
 141 If number of entries in a menu is larger than this value, split menu
 142 into submenus of nearly equal length.  If nil, never split menu into
 143 submenus."
 144   :group 'font-menu
 145   :type '(choice (const :tag "no submenus" nil)
 146                  (integer)))
 147
 148 (defcustom font-menu-submenu-name-format "%-12.12s ... %.12s"
 149   "*Format specification of the submenu name.
 150 Used by `font-menu-split-long-menu' if the number of entries in a menu is
 151 larger than `font-menu-menu-max-items'.
 152 This string should contain one %s for the name of the first entry and
 153 one %s for the name of the last entry in the submenu.
 154 If the value is a function, it should return the submenu name.  The
 155 function is be called with two arguments, the names of the first and
 156 the last entry in the menu."
 157   :group 'font-menu
 158   :type '(choice (string :tag "Format string")
 159                  (function)))
 160
 161 (defvar font-menu-preferred-resolution
 162   (make-specifier-and-init 'generic '((global ((mswindows) . ":")
 163                                               ((x) . "*-*"))) t)
 164   "Preferred horizontal and vertical font menu resolution (e.g. \"75:75\").")
 165
 166 (defvar font-menu-size-scaling
 167   (make-specifier-and-init 'integer '((global ((mswindows) . 1)
 168                                               ((x) . 10))) t)
 169   "Scale factor used in defining font sizes.")
 170
 171 (defun vassoc (key valist)
 172   "Search VALIST for a vector whose first element is equal to KEY.
 173 See also `assoc'."
 174   ;; by Stig@hackvan.com
 175   (let (el)
 176     (catch 'done
 177       (while (setq el (pop valist))
 178         (and (equal key (aref el 0))
 179              (throw 'done el))))))
 180
 181 ;; only call XListFonts (and parse) once per device.
 182 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
 183 (defvar device-fonts-cache nil)
 184
 185 (defsubst device-fonts-cache ()
 186   (or (cdr (assq (selected-device) device-fonts-cache))
 187       (and (reset-device-font-menus (selected-device))
 188            (cdr (assq (selected-device) device-fonts-cache)))))
 189
 190 ;;;###autoload
 191 (fset 'install-font-menus 'reset-device-font-menus)
 192 (make-obsolete 'install-font-menus 'reset-device-font-menus)
 193
 194 ;;;###autoload
 195 (defun reset-device-font-menus (&optional device debug)
 196   "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
 197 This is run the first time that a font-menu is needed for each device.
 198 If you don't like the lazy invocation of this function, you can add it to
 199 `create-device-hook' and that will make the font menus respond more quickly
 200 when they are selected for the first time.  If you add fonts to your system,
 201 or if you change your font path, you can call this to re-initialize the menus."
 202   (message "Getting list of fonts from server... ")
 203   (if (or noninteractive
 204           (not (or device (setq device (selected-device)))))
 205       nil
 206     (call-device-method 'reset-device-font-menus device device debug)
 207     (message "Getting list of fonts from server... done.")))
 208
 209 (defun font-menu-split-long-menu (menu)
 210   "Split MENU according to `font-menu-max-items'."
 211   (let ((len (length menu)))
 212     (if (or (null font-menu-max-items)
 213             (null (featurep 'lisp-float-type))
 214             (<= len font-menu-max-items))
 215         menu
 216       ;; Submenu is max 2 entries longer than menu, never shorter, number of
 217       ;; entries in submenus differ by at most one (with longer submenus first)
 218       (let* ((outer (floor (sqrt len)))
 219              (inner (/ len outer))
 220              (rest (% len outer))
 221              (result nil))
 222         (setq menu (reverse menu))
 223         (while menu
 224           (let ((in inner)
 225                 (sub nil)
 226                 (to (car menu)))
 227             (while (> in 0)
 228               (setq in   (1- in)
 229                     sub  (cons (car menu) sub)
 230                     menu (cdr menu)))
 231             (setq result
 232                   (cons (cons (if (stringp font-menu-submenu-name-format)
 233                                   (format font-menu-submenu-name-format
 234                                           (aref (car sub) 0) (aref to 0))
 235                                 (funcall font-menu-submenu-name-format
 236                                          (aref (car sub) 0) (aref to 0)))
 237                               sub)
 238                         result)
 239                   rest  (1+ rest))
 240             (if (= rest outer) (setq inner (1+ inner)))))
 241         result))))
 242
 243 ;;;###autoload
 244 (defun font-menu-family-constructor (ignored)
 245   (catch 'menu
 246     (unless (console-on-window-system-p)
 247       (throw 'menu '(["Cannot parse current font" ding nil])))
 248     (let* ((dcache (device-fonts-cache))
 249            (font-data (font-menu-font-data 'default dcache))
 250            (entry  (aref font-data 0))
 251            (family (aref font-data 1))
 252            (size   (aref font-data 2))
 253            (weight (aref font-data 3))
 254            f)
 255       (unless family
 256         (throw 'menu '(["Cannot parse current font" ding nil])))
 257       ;; Items on the Font menu are enabled iff that font exists in
 258       ;; the same size and weight as the current font (scalable fonts
 259       ;; exist in every size).  Only the current font is marked as
 260       ;; selected.
 261       (font-menu-split-long-menu
 262        (mapcar
 263         (lambda (item)
 264           (setq f (aref item 0)
 265                 entry (vassoc f (aref dcache 0)))
 266           (if (and (or (member weight (aref entry 1))
 267                        ;; mswindows often allows any weight
 268                        (member "" (aref entry 1)))
 269                    (or (member size (aref entry 2))
 270                        (and (not font-menu-ignore-scaled-fonts)
 271                             (member 0 (aref entry 2)))))
 272               (enable-menu-item item)
 273             (disable-menu-item item))
 274           (if (string-equal family f)
 275               (select-toggle-menu-item item)
 276             (deselect-toggle-menu-item item))
 277           item)
 278         (aref dcache 1))))))
 279
 280 (define-device-method* font-menu-font-data)
 281
 282 ;;;###autoload
 283 (defun font-menu-size-constructor (ignored)
 284   (catch 'menu
 285     (unless (console-on-window-system-p)
 286       (throw 'menu '(["Cannot parse current font" ding nil])))
 287     (let* ((dcache (device-fonts-cache))
 288            (font-data (font-menu-font-data 'default dcache))
 289            (entry  (aref font-data 0))
 290            (family (aref font-data 1))
 291            (size   (aref font-data 2))
 292            ;;(weight (aref font-data 3))
 293            s)
 294       (unless family
 295         (throw 'menu '(["Cannot parse current font" ding nil])))
 296       ;; Items on the Size menu are enabled iff current font has
 297       ;; that size.  Only the size of the current font is selected.
 298       ;; (If the current font comes in size 0, it is scalable, and
 299       ;; thus has every size.)
 300       (mapcar
 301        (lambda (item)
 302          (setq s (nth 3 (aref item 1)))
 303          (if (or (member s (aref entry 2))
 304                  (and (not font-menu-ignore-scaled-fonts)
 305                       (member 0 (aref entry 2))))
 306              (enable-menu-item item)
 307            (disable-menu-item item))
 308          (if (eq size s)
 309              (select-toggle-menu-item item)
 310            (deselect-toggle-menu-item item))
 311          item)
 312        (aref dcache 2)))))
 313
 314 ;;;###autoload
 315 (defun font-menu-weight-constructor (ignored)
 316   (catch 'menu
 317     (unless (console-on-window-system-p)
 318       (throw 'menu '(["Cannot parse current font" ding nil])))
 319     (let* ((dcache (device-fonts-cache))
 320            (font-data (font-menu-font-data 'default dcache))
 321            (entry  (aref font-data 0))
 322            (family (aref font-data 1))
 323            ;;(size   (aref font-data 2))
 324            (weight (aref font-data 3))
 325            w)
 326       (unless family
 327         (throw 'menu '(["Cannot parse current font" ding nil])))
 328       ;; Items on the Weight menu are enabled iff current font
 329       ;; has that weight.  Only the weight of the current font
 330       ;; is selected.
 331       (mapcar
 332        (lambda (item)
 333          (setq w (aref item 0))
 334          (if (member w (aref entry 1))
 335              (enable-menu-item item)
 336            (disable-menu-item item))
 337          (if (string-equal weight w)
 338              (select-toggle-menu-item item)
 339            (deselect-toggle-menu-item item))
 340          item)
 341        (aref dcache 3)))))
 342
 343 \f
 344 ;;; Changing font sizes
 345
 346 (defun font-menu-set-font (family weight size)
 347   ;; This is what gets run when an item is selected from any of the three
 348   ;; fonts menus.  It needs to be rather clever.
 349   ;; (size is measured in 10ths of points.)
 350   (let* ((dcache (device-fonts-cache))
 351          (font-data (font-menu-font-data 'default dcache))
 352          (from-family (aref font-data 1))
 353          (from-size   (aref font-data 2))
 354          (from-weight (aref font-data 3))
 355          (from-slant  (aref font-data 4))
 356          (face-list-to-change (delq 'default (face-list)))
 357          new-default-face-font
 358          new-props)
 359     (unless from-family
 360       (signal 'error '("couldn't parse font name for default face")))
 361     (when weight
 362       (signal 'error '("Setting weight currently not supported")))
 363     (setq new-default-face-font
 364           (font-menu-load-font
 365            (or family from-family)
 366            (or weight from-weight)
 367            (or size   from-size)
 368            from-slant
 369            (specifier-instance
 370             font-menu-preferred-resolution (selected-device))))
 371     ;; This is such a gross hack. The border-glyph face under
 372     ;; mswindows is in a symbol font. Thus it will not appear in the
 373     ;; cache - being a junk family.  What we should do is change the
 374     ;; size but not the family, but this is more work than I care to
 375     ;; invest at the moment.
 376     (when (eq (device-type) 'mswindows)
 377       (setq face-list-to-change
 378             (delq 'border-glyph face-list-to-change)))
 379     (dolist (face face-list-to-change)
 380       (when (face-font-instance face)
 381         (message "Changing font of `%s'..." face)
 382         (condition-case c
 383             (font-menu-change-face face
 384                                    from-family from-weight from-size
 385                                    family      weight      size)
 386           (error
 387            (display-error c nil)
 388            (sit-for 1)))))
 389     ;; Set the default face's font after hacking the other faces, so that
 390     ;; the frame size doesn't change until we are all done.
 391
 392     ;; If we need to be frame local we do the changes ourselves.
 393     (if font-menu-this-frame-only-p
 394     ;;; WMP - we need to honor font-menu-this-frame-only-p here!
 395         (set-face-font 'default new-default-face-font
 396                        (and font-menu-this-frame-only-p (selected-frame)))
 397       ;; OK Let Customize do it.
 398       (when (and family (not (equal family from-family)))
 399         (setq new-props (append (list :family family) new-props)))
 400       (when (and size (not (equal size from-size)))
 401         (setq new-props (append
 402            (list :size (concat (int-to-string (/ size (specifier-instance
 403                                                        font-menu-size-scaling
 404                                                        (selected-device)))) "pt")) new-props)))
 405       (custom-set-face-update-spec 'default '((type x)) new-props)
 406       (message "Font %s" (face-font-name 'default)))))
 407
 408
 409 (defun font-menu-change-face (face
 410                               from-family from-weight from-size
 411                               to-family   to-weight   to-size)
 412   (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
 413   (let* ((dcache (device-fonts-cache))
 414          (font-data (font-menu-font-data face dcache))
 415          (face-family (aref font-data 1))
 416          (face-size   (aref font-data 2))
 417          (face-weight (aref font-data 3))
 418          (face-slant  (aref font-data 4)))
 419
 420     (or face-family
 421         (signal 'error (list "couldn't parse font name for face" face)))
 422
 423     ;; If this face matches the old default face in the attribute we
 424     ;; are changing, then change it to the new attribute along that
 425     ;; dimension.  Also, the face must have its own global attribute.
 426     ;; If its value is inherited, we don't touch it.  If any of this
 427     ;; is not true, we leave it alone.
 428     (when (and (face-font face 'global)
 429                (cond
 430                 (to-family (string-equal face-family from-family))
 431                 (to-weight (string-equal face-weight from-weight))
 432                 (to-size   (=            face-size   from-size))))
 433       (set-face-font face
 434                      (font-menu-load-font (or to-family face-family)
 435                                           (or to-weight face-weight)
 436                                           (or to-size   face-size)
 437                                           face-slant
 438                                           (specifier-instance
 439                                            font-menu-preferred-resolution
 440                                            (selected-device)))
 441                      (and font-menu-this-frame-only-p
 442                           (selected-frame))))))
 443
 444 (define-device-method font-menu-load-font)
 445
 446 (defun flush-device-fonts-cache (device)
 447   ;; by Stig@hackvan.com
 448   (let ((elt (assq device device-fonts-cache)))
 449     (and elt
 450          (setq device-fonts-cache (delq elt device-fonts-cache)))))
 451
 452 (add-hook 'delete-device-hook 'flush-device-fonts-cache)
 453
 454 (provide 'font-menu)
 455
 456 ;; font-menu ends here