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@jwz.org>
   8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
   9 ;; Mule-ized by: Martin Buchholz
  10 ;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org>
  11
  12 ;; This file is part of XEmacs.
  13
  14 ;; XEmacs is free software; you can redistribute it and/or modify it
  15 ;; under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; XEmacs is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with XEmacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28 ;;; Code:
  29
  30 ;; #### - implement these...
  31 ;;
  32 ;;; (defvar font-menu-ignore-proportional-fonts nil
  33 ;;;   "*If non-nil, then the font menu will only show fixed-width fonts.")
  34
  35 (require 'font-menu)
  36
  37 (defvar x-font-menu-registry-encoding nil
  38   "Registry and encoding to use with font menu fonts.")
  39
  40 (defvar x-fonts-menu-junk-families
  41   (mapconcat
  42    #'identity
  43    '("cursor" "glyph" "symbol"  ; Obvious losers.
  44      "\\`Ax...\\'"              ; FrameMaker fonts - there are just way too
  45                                 ;  many of these, and there is a different
  46                                 ;  font family for each font face!  Losers.
  47                                 ;  "Axcor" -> "Applix Courier Roman",
  48                                 ;  "Axcob" -> "Applix Courier Bold", etc.
  49      )
  50    "\\|")
  51   "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
  52
  53 (defun hack-font-truename (fn)
  54   "Filter the output of `font-instance-truename' to deal with Japanese fontsets."
  55   (if (string-match "," (font-instance-truename fn))
  56       (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-")))
  57             (flist (split-string (font-instance-truename fn) ","))
  58             ret)
  59         (while flist
  60           (if (string-equal fpnt (nth 8 (split-string (car flist) "-")))
  61               (progn (setq ret (car flist)) (setq flist nil))
  62             (setq flist (cdr flist))
  63             ))
  64         ret)
  65     (font-instance-truename fn)))
  66
  67 (defvar x-font-regexp-ascii nil
  68   "This is used to filter out font families that can't display ASCII text.
  69 It must be set at run-time.")
  70
  71 ;;;###autoload
  72 (defun x-reset-device-font-menus (device &optional debug)
  73   "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
  74 This is run the first time that a font-menu is needed for each device.
  75 If you don't like the lazy invocation of this function, you can add it to
  76 `create-device-hook' and that will make the font menus respond more quickly
  77 when they are selected for the first time.  If you add fonts to your system,
  78 or if you change your font path, you can call this to re-initialize the menus."
  79   ;; by Stig@hackvan.com
  80   ;; #### - this should implement a `menus-only' option, which would
  81   ;; recalculate the menus from the cache w/o having to do list-fonts again.
  82   (unless x-font-regexp-ascii
  83     (setq x-font-regexp-ascii (if (featurep 'mule)
  84                                   (charset-registry 'ascii)
  85                                 "iso8859-1")))
  86   (setq x-font-menu-registry-encoding
  87         (if (featurep 'mule) "*-*" "iso8859-1"))
  88   (let ((case-fold-search t)
  89         family size weight entry monospaced-p
  90         dev-cache cache families sizes weights)
  91     (dolist (name (cond ((null debug)   ; debugging kludge
  92                          (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
  93                         ((stringp debug) (split-string debug "\n"))
  94                         (t debug)))
  95       (when (and (string-match x-font-regexp-ascii name)
  96                  (string-match x-font-regexp name))
  97         (setq weight (capitalize (match-string 1 name))
  98               size   (string-to-int (match-string 6 name)))
  99         (or (string-match x-font-regexp-foundry-and-family name)
 100             (error "internal error"))
 101         (setq family (capitalize (match-string 1 name)))
 102         (or (string-match x-font-regexp-spacing name)
 103             (error "internal error"))
 104         (setq monospaced-p (string= "m" (match-string 1 name)))
 105         (unless (string-match x-fonts-menu-junk-families family)
 106           (setq entry (or (vassoc family cache)
 107                           (car (setq cache
 108                                      (cons (vector family nil nil t)
 109                                            cache)))))
 110           (or (member family families) (push family families))
 111           (or (member weight weights)  (push weight weights))
 112           (or (member size   sizes)    (push size   sizes))
 113           (or (member weight (aref entry 1)) (push weight (aref entry 1)))
 114           (or (member size   (aref entry 2)) (push size   (aref entry 2)))
 115           (aset entry 3 (and (aref entry 3) monospaced-p)))))
 116     ;;
 117     ;; Hack scalable fonts.
 118     ;; Some fonts come only in scalable versions (the only size is 0)
 119     ;; and some fonts come in both scalable and non-scalable versions
 120     ;; (one size is 0).  If there are any scalable fonts at all, make
 121     ;; sure that the union of all point sizes contains at least some
 122     ;; common sizes - it's possible that some sensible sizes might end
 123     ;; up not getting mentioned explicitly.
 124     ;;
 125     (if (member 0 sizes)
 126         (let ((common '(60 80 100 120 140 160 180 240)))
 127           (while common
 128             (or;;(member (car common) sizes)   ; not enough slack
 129              (let ((rest sizes)
 130                    (done nil))
 131                (while (and (not done) rest)
 132                  (if (and (> (car common) (- (car rest) 5))
 133                           (< (car common) (+ (car rest) 5)))
 134                      (setq done t))
 135                  (setq rest (cdr rest)))
 136                done)
 137              (setq sizes (cons (car common) sizes)))
 138             (setq common (cdr common)))
 139           (setq sizes (delq 0 sizes))))
 140
 141     (setq families (sort families 'string-lessp)
 142           weights  (sort weights 'string-lessp)
 143           sizes    (sort sizes '<))
 144
 145     (dolist (entry cache)
 146       (aset entry 1 (sort (aref entry 1) 'string-lessp))
 147       (aset entry 2 (sort (aref entry 2) '<)))
 148
 149     (setq dev-cache (assq device device-fonts-cache))
 150     (or dev-cache
 151         (setq dev-cache (car (push (list device) device-fonts-cache))))
 152     (setcdr
 153      dev-cache
 154      (vector
 155       cache
 156       (mapcar (lambda (x)
 157                 (vector x
 158                         (list 'font-menu-set-font x nil nil)
 159                         ':style 'radio ':active nil ':selected nil))
 160               families)
 161       (mapcar (lambda (x)
 162                 (vector (if (/= 0 (% x 10))
 163                             ;; works with no LISP_FLOAT_TYPE
 164                             (concat (int-to-string (/ x 10)) "."
 165                                     (int-to-string (% x 10)))
 166                           (int-to-string (/ x 10)))
 167                         (list 'font-menu-set-font nil nil x)
 168                         ':style 'radio ':active nil ':selected nil))
 169               sizes)
 170       (mapcar (lambda (x)
 171                 (vector x
 172                         (list 'font-menu-set-font nil x nil)
 173                         ':style 'radio ':active nil ':selected nil))
 174               weights)))
 175     (cdr dev-cache)))
 176
 177 ;; Extract font information from a face.  We examine both the
 178 ;; user-specified font name and the canonical (`true') font name.
 179 ;; These can appear to have totally different properties.
 180 ;; For examples, see the prolog above.
 181
 182 ;; We use the user-specified one if possible, else use the truename.
 183 ;; If the user didn't specify one (with "-dt-*-*", for example)
 184 ;; get the truename and use the possibly suboptimal data from that.
 185 ;;;###autoload
 186 (defun* x-font-menu-font-data (face dcache)
 187   (defvar x-font-regexp)
 188   (defvar x-font-regexp-foundry-and-family)
 189   (let* ((case-fold-search t)
 190          (domain (if font-menu-this-frame-only-p
 191                                   (selected-frame)
 192                                 (selected-device)))
 193          (name (font-instance-name (face-font-instance face domain)))
 194          (truename (font-instance-truename
 195                     (face-font-instance face domain
 196                                         (if (featurep 'mule) 'ascii))))
 197          family size weight entry slant)
 198     (when (string-match x-font-regexp-foundry-and-family name)
 199       (setq family (capitalize (match-string 1 name)))
 200       (setq entry (vassoc family (aref dcache 0))))
 201     (when (and (null entry)
 202                (string-match x-font-regexp-foundry-and-family truename))
 203       (setq family (capitalize (match-string 1 truename)))
 204       (setq entry  (vassoc family (aref dcache 0))))
 205     (when (null entry)
 206       (return-from x-font-menu-font-data (make-vector 5 nil)))
 207
 208     (when (string-match x-font-regexp name)
 209       (setq weight (capitalize    (match-string 1 name)))
 210       (setq size   (string-to-int (match-string 6 name))))
 211
 212     (when (string-match x-font-regexp truename)
 213       (when (not (member weight (aref entry 1)))
 214         (setq weight (capitalize (match-string 1 truename))))
 215       (when (not (member size   (aref entry 2)))
 216         (setq size (string-to-int (match-string 6 truename))))
 217       (setq slant (capitalize (match-string 2 truename))))
 218
 219     (vector entry family size weight slant)))
 220
 221 (defun x-font-menu-load-font (family weight size slant resolution)
 222   "Try to load a font with the requested properties.
 223 The weight, slant and resolution are only hints."
 224   (when (integerp size) (setq size (int-to-string size)))
 225   (let (font)
 226     (catch 'got-font
 227       (dolist (weight (list weight "*"))
 228         (dolist (slant
 229                  (cond ((string-equal slant "O") '("O" "I" "*"))
 230                        ((string-equal slant "I") '("I" "O" "*"))
 231                        ((string-equal slant "*") '("*"))
 232                        (t (list slant "*"))))
 233           (dolist (resolution
 234                    (if (string-equal resolution "*-*")
 235                        (list resolution)
 236                      (list resolution "*-*")))
 237             (when (setq font
 238                         (make-font-instance
 239                          (concat  "-*-" family "-" weight "-" slant "-*-*-*-"
 240                                   size "-" resolution "-*-*-"
 241                                   x-font-menu-registry-encoding)
 242                          nil t))
 243               (throw 'got-font font))))))))
 244
 245 (provide 'x-font-menu)
 246
 247 ;;; x-font-menu.el ends here