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

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