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