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