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