1 ;; gtk-font-menu.el --- Managing menus of GTK fonts.
3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1997 Sun Microsystems
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>
13 ;; This file is part of XEmacs.
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)
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.
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.
31 ;; #### - implement these...
33 ;;; (defvar font-menu-ignore-proportional-fonts nil
34 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.")
38 (defvar gtk-font-menu-registry-encoding nil
39 "Registry and encoding to use with font menu fonts.")
41 (defvar gtk-fonts-menu-junk-families
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.
52 "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
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) ","))
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))
66 (font-instance-truename fn)))
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.")
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)
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"))
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)
109 (cons (vector family nil nil t)
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)))))
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.
127 (let ((common '(60 80 100 120 140 160 180 240)))
129 (or;;(member (car common) sizes) ; not enough slack
132 (while (and (not done) rest)
133 (if (and (> (car common) (- (car rest) 5))
134 (< (car common) (+ (car rest) 5)))
136 (setq rest (cdr rest)))
138 (setq sizes (cons (car common) sizes)))
139 (setq common (cdr common)))
140 (setq sizes (delq 0 sizes))))
142 (setq families (sort families 'string-lessp)
143 weights (sort weights 'string-lessp)
144 sizes (sort sizes '<))
146 (dolist (entry cache)
147 (aset entry 1 (sort (aref entry 1) 'string-lessp))
148 (aset entry 2 (sort (aref entry 2) '<)))
150 (setq dev-cache (assq device device-fonts-cache))
152 (setq dev-cache (car (push (list device) device-fonts-cache))))
159 (list 'font-menu-set-font x nil nil)
160 ':style 'radio ':active nil ':selected nil))
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))
173 (list 'font-menu-set-font nil x nil)
174 ':style 'radio ':active nil ':selected nil))
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.
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.
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
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))))
207 (return-from gtk-font-menu-font-data (make-vector 5 nil)))
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))))
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))))
220 (vector entry family size weight slant)))
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)))
228 (dolist (weight (list weight "*"))
230 (cond ((string-equal slant "O") '("O" "I" "*"))
231 ((string-equal slant "I") '("I" "O" "*"))
232 ((string-equal slant "*") '("*"))
233 (t (list slant "*"))))
235 (if (string-equal resolution "*-*")
237 (list resolution "*-*")))
240 (concat "-*-" family "-" weight "-" slant "-*-*-*-"
241 size "-" resolution "-*-*-"
242 gtk-font-menu-registry-encoding)
244 (throw 'got-font font))))))))
246 (provide 'gtk-font-menu)
248 ;;; gtk-font-menu.el ends here